New module for C and Haskell memory throughput benchmark

Haskell wrapper for the C code plus pure Haskell impl
Interestingly the Haskell byte versions seem excessively slow
in comparison to the Haskell word versions.

tests/CBenchmark.c

-#include <time.h>
-#include <stdlib.h>
-#include <stdio.h>
+#include "CBenchmark.h"
 
-const int mb = 10;
-const int bytes = 1024 * 1024 * 100;
-
-void bytewrite(unsigned char *a);
-unsigned char byteread(unsigned char *a);
-void wordwrite(unsigned int *a);
-unsigned int wordread(unsigned int *a);
-
-int main() {
-  unsigned char *a = malloc(bytes);
-
-  bytewrite(a);
-  //wordwrite((unsigned int *)a);
-  //byteread(a);
-  //wordread((unsigned int *)a);
-
-  return 0;
-}
-
-void bytewrite(unsigned char *a) {
+void bytewrite(unsigned char *a, int bytes) {
   unsigned char n = 0;
   int i = 0;
   int iterations = bytes;
@@ -30,7 +9,7 @@ void bytewrite(unsigned char *a) {
   }
 }
 
-unsigned char byteread(unsigned char *a) {
+unsigned char byteread(unsigned char *a, int bytes) {
   unsigned char n = 0;
   int i = 0;
   int iterations = bytes;
@@ -40,7 +19,7 @@ unsigned char byteread(unsigned char *a) {
   return n;
 }
 
-void wordwrite(unsigned int *a) {
+void wordwrite(unsigned int *a, int bytes) {
   unsigned int n = 0;
   int i = 0;
   int iterations = bytes / sizeof(unsigned int) ;
@@ -49,7 +28,7 @@ void wordwrite(unsigned int *a) {
   }
 }
 
-unsigned int wordread(unsigned int *a) {
+unsigned int wordread(unsigned int *a, int bytes) {
   unsigned int n = 0;
   int i = 0;
   int iterations = bytes / sizeof(unsigned int);

tests/CBenchmark.h

+void bytewrite(unsigned char *a, int bytes);
+unsigned char byteread(unsigned char *a, int bytes);
+void wordwrite(unsigned int *a, int bytes);
+unsigned int wordread(unsigned int *a, int bytes);

tests/MemBench.hs

+{-# OPTIONS_GHC -fffi -fbang-patterns #-}
+module MemBench (memBench) where
+
+import Foreign
+import Foreign.C
+
+import Control.Exception
+import System.CPUTime
+import Numeric
+
+memBench :: Int -> IO ()
+memBench mb = do
+  let bytes = mb * 2^20
+  allocaBytes bytes $ \ptr -> do
+    let bench label test = do
+          seconds <- time $ test (castPtr ptr) (fromIntegral bytes)
+          let throughput = fromIntegral mb / seconds
+          putStrLn $ show mb ++ "MB of " ++ label
+                  ++ " in " ++ showFFloat (Just 3) seconds "s, at: "
+                  ++ showFFloat (Just 1) throughput "MB/s"
+    bench "setup        " c_wordwrite
+    putStrLn ""
+    putStrLn "C memory throughput benchmarks:"
+    bench "bytes written" c_bytewrite
+    bench "bytes read   " c_byteread
+    bench "words written" c_wordwrite
+    bench "words read   " c_wordread
+    putStrLn ""
+    putStrLn "Haskell memory throughput benchmarks:"
+    bench "bytes written" hs_bytewrite
+    bench "bytes read   " hs_byteread
+    bench "words written" hs_wordwrite
+    bench "words read   " hs_wordread
+
+hs_bytewrite  :: Ptr CUChar -> Int -> IO ()
+hs_bytewrite ptr bytes = loop 0 0
+  where iterations = bytes
+        loop :: Int -> CUChar -> IO ()
+        loop !i !n | i == iterations = return ()
+                   | otherwise = do pokeByteOff ptr i n
+                                    loop (i+1) (n+1)
+
+hs_byteread  :: Ptr CUChar -> Int -> IO CUChar
+hs_byteread ptr bytes = loop 0 0
+  where iterations = bytes
+        loop :: Int -> CUChar -> IO CUChar
+        loop !i !n | i == iterations = return n
+                   | otherwise = do x <- peekByteOff ptr i
+                                    loop (i+1) (n+x)
+
+hs_wordwrite :: Ptr CUInt -> Int -> IO ()
+hs_wordwrite ptr bytes = loop 0 0
+  where iterations = bytes `div` sizeOf (undefined :: CUInt)
+        loop :: Int -> CUInt -> IO ()
+        loop !i !n | i == iterations = return ()
+                   | otherwise = do pokeByteOff ptr i n
+                                    loop (i+1) (n+1)
+
+hs_wordread  :: Ptr CUInt -> Int -> IO CUInt
+hs_wordread ptr bytes = loop 0 0
+  where iterations = bytes `div` sizeOf (undefined :: CUInt)
+        loop :: Int -> CUInt -> IO CUInt
+        loop !i !n | i == iterations = return n
+                   | otherwise = do x <- peekByteOff ptr i
+                                    loop (i+1) (n+x)
+
+
+foreign import ccall unsafe "CBenchmark.h byteread"
+  c_byteread :: Ptr CUChar -> CInt -> IO ()
+
+foreign import ccall unsafe "CBenchmark.h bytewrite"
+  c_bytewrite :: Ptr CUChar -> CInt -> IO ()
+
+foreign import ccall unsafe "CBenchmark.h wordread"
+  c_wordread :: Ptr CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "CBenchmark.h wordwrite"
+  c_wordwrite :: Ptr CUInt -> CInt -> IO ()
+
+time :: IO a -> IO Double
+time action = do
+    start <- getCPUTime
+    action
+    end   <- getCPUTime
+    return $! (fromIntegral (end - start)) / (10^12)