Get benchmarking ever so very slightly working.

benchmarks/Args.hs

@@ -0,0 +1,63 @@
+module Args
+    (
+      theLast
+    , ljust
+    , parseArgs
+    , positive
+    ) where
+
+import Data.Monoid (Monoid(..), Last(..), getLast)
+import System.Console.GetOpt (OptDescr, ArgOrder(Permute), getOpt, usageInfo)
+import System.Environment (getArgs, getProgName)
+import System.Exit (ExitCode(..), exitWith)
+import System.IO (hPutStrLn, stderr)
+
+-- | Deconstructor for 'Last' values.
+theLast :: (cfg -> Last a)    -- ^ Field to access.
+        -> cfg
+        -> a
+theLast f cfg = case f cfg of
+                  Last Nothing  -> error "some horrible config sin has occurred"
+                  Last (Just a) -> a
+
+-- | Parse command line options.
+parseArgs :: Monoid cfg => cfg -> [OptDescr (IO cfg)] -> [String]
+          -> IO (cfg, [String])
+parseArgs defCfg options args =
+  case getOpt Permute options args of
+    (_, _, (err:_)) -> parseError err
+    (opts, rest, _) -> do
+      cfg <- (mappend defCfg . mconcat) `fmap` sequence opts
+      return (cfg, rest)
+
+-- | Constructor for 'Last' values.
+ljust :: a -> Last a
+ljust = Last . Just
+
+-- | Parse a positive number.
+positive :: (Num a, Ord a, Read a) =>
+            String -> (Last a -> cfg) -> String -> IO cfg
+positive q f s =
+    case reads s of
+      [(n,"")] | n > 0     -> return . f $ ljust n
+               | otherwise -> parseError $ q ++ " must be positive"
+      _                    -> parseError $ "invalid " ++ q ++ " provided"
+
+-- | Display an error message from a command line parsing failure, and
+-- exit.
+parseError :: String -> IO a
+parseError msg = do
+  progName <- getProgName
+  hPutStrLn stderr $ "Error: " ++ msg
+  hPutStrLn stderr $ "Run \"" ++ progName ++ " --help\" for usage information\n"
+  exitWith (ExitFailure 64)
+
+printUsage :: [OptDescr b] -> ExitCode -> IO a
+printUsage options exitCode = do
+  p <- getProgName
+  putStr (usageInfo ("Usage: " ++ p ++ " [OPTIONS] [ARGS]") options)
+  mapM_ putStrLn [
+       ""
+     , "hi mom!"
+    ]
+  exitWith exitCode

benchmarks/Simple.hs

@@ -7,26 +7,105 @@
 
 module Main where
 
-import Control.Monad
-import Data.Array.IArray
-import Data.Array.Unboxed
-import System.Posix.IO
-import System.Posix.Resource
-import System.Posix.Types
+import Args (ljust, parseArgs, positive, theLast)
+import Control.Monad (forM_, replicateM, when)
+import Data.Array.Unboxed (UArray, listArray)
+import Data.Function (on)
+import Data.IORef (IORef, atomicModifyIORef, newIORef)
+import Data.Int (Int32)
+import Data.Monoid (Monoid(..), Last(..), getLast)
+import Foreign.C.Error (throwErrnoIfMinus1Retry)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (Ptr)
+import Foreign.C.Types (CChar)
+import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
+import System.Environment (getArgs)
+import System.Event (Event(..), loop, new, registerFd)
+import System.Posix.IO (createPipe)
+import System.Posix.Resource (ResourceLimit(..), ResourceLimits(..),
+                              Resource(..), setResourceLimit)
+import System.Posix.Internals (c_close, c_read, c_write)
+import System.Posix.Types (Fd(..))
 
-numPipes :: Int
-numPipes = 1024
+data Config = Config {
+      cfgNumPipes :: Last Int
+    }
+
+defaultConfig :: Config
+defaultConfig = Config {
+                  cfgNumPipes = ljust 1024
+                }
+
+instance Monoid Config where
+    mempty  = Config {
+                cfgNumPipes = mempty
+              }
+    mappend a b = Config {
+                    cfgNumPipes = app cfgNumPipes a b
+                  }
+        where app = on mappend
+
+defaultOptions :: [OptDescr (IO Config)]
+defaultOptions = [
+  Option ['n'] ["num-pipes"]
+         (ReqArg (positive "number of pipes" $ \n -> mempty { cfgNumPipes = n }) "N")
+          "number of pipes to use"
+ ]
+
+readCallback :: IORef Int -> Fd -> [Event] -> IO ()
+readCallback ref fd _ = do
+  a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
+  if a > 10
+    then close fd
+    else do
+      print ("read",fd)
+      readByte fd
+
+writeCallback :: IORef Int -> Fd -> [Event] -> IO ()
+writeCallback ref fd _ = do
+  a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
+  if a > 10
+    then close fd
+    else do
+      print ("write",fd)
+      writeByte fd
 
 main :: IO ()
 main = do
-    -- Increase the maximum number of file descriptors to fit the
-    -- number of pipes.
-    let lim = ResourceLimit $ fromIntegral numPipes * 2 + 50
+    (cfg, args) <- parseArgs defaultConfig defaultOptions =<< getArgs
+    let numPipes = theLast cfgNumPipes cfg
+        lim = ResourceLimit $ fromIntegral numPipes * 2 + 50
     setResourceLimit ResourceOpenFiles
         ResourceLimits { softLimit = lim, hardLimit = lim }
 
-    -- Create the pipes.
-    ps <- concatMap (\(Fd x, Fd y) -> [fromIntegral x, fromIntegral y]) `fmap`
-          replicateM numPipes createPipe
-    let pipes = listArray (0, numPipes) ps :: UArray Int Int
-    return ()
+    pipePairs <- replicateM numPipes createPipe
+    print pipePairs
+    let pipes = concatMap (\(r,w) -> [r,w]) pipePairs
+
+    mgr <- new
+    rref <- newIORef 0
+    wref <- newIORef 0
+    forM_ pipePairs $ \(r,w) -> do
+      registerFd mgr (readCallback rref r) r [Read]
+      registerFd mgr (writeCallback wref w) w [Write]
+
+    let pipeArray :: UArray Int Int32
+        pipeArray = listArray (0, numPipes) . map fromIntegral $ pipes
+    loop mgr
+
+readByte :: Fd -> IO ()
+readByte (Fd fd) =
+    alloca $ \p -> do
+      n <- throwErrnoIfMinus1Retry "readByte" $ c_read fd p 1
+      when (n /= 1) . error $ "readByte returned " ++ show n
+
+writeByte :: Fd -> IO ()
+writeByte (Fd fd) =
+    alloca $ \p -> do
+      n <- throwErrnoIfMinus1Retry "writeByte" $ c_write fd p 1
+      when (n /= 1) . error $ "writeByte returned " ++ show n
+
+close :: Fd -> IO ()
+close (Fd fd) = do
+  c_close fd
+  return ()