Benchmarking and QuickChecking readInt.

ParseInt64.c

#line 1 "ParseInt64.rl"
#include <HsFFI.h>


#line 7 "ParseInt64.c"
static const int ParseInt64_start = 1;
static const int ParseInt64_first_final = 3;
static const int ParseInt64_error = 0;

static const int ParseInt64_en_main = 1;


#line 6 "ParseInt64.rl"


HsBool parseInt64(const HsWord8* buffer, HsInt off, HsInt length, HsInt64* value)
{
    const HsWord8* p = &buffer[off];
    const HsWord8* pe = &buffer[off+length];

    int cs;
    HsInt64 val = 0;
    int neg = 0;

    
#line 28 "ParseInt64.c"
	{
	cs = ParseInt64_start;
	}

#line 33 "ParseInt64.c"
	{
	if ( p == pe )
		goto _test_eof;
	switch ( cs )
	{
case 1:
	switch( (*p) ) {
		case 43: goto st2;
		case 45: goto tr2;
	}
	if ( 48 <= (*p) && (*p) <= 57 )
		goto tr3;
	goto st0;
st0:
cs = 0;
	goto _out;
tr2:
#line 18 "ParseInt64.rl"
	{
            neg = 1;
        }
	goto st2;
st2:
	if ( ++p == pe )
		goto _test_eof2;
case 2:
#line 60 "ParseInt64.c"
	if ( 48 <= (*p) && (*p) <= 57 )
		goto tr3;
	goto st0;
tr3:
#line 22 "ParseInt64.rl"
	{ 
            const HsInt64 old = val;
            val = val * 10 + ((*p) - '0');
            if (val < old) {
                return HS_BOOL_FALSE;
            }
        }
	goto st3;
st3:
	if ( ++p == pe )
		goto _test_eof3;
case 3:
#line 78 "ParseInt64.c"
	switch( (*p) ) {
		case 0: goto st4;
		case 13: goto st4;
		case 32: goto st4;
	}
	if ( (*p) > 10 ) {
		if ( 48 <= (*p) && (*p) <= 57 )
			goto tr3;
	} else if ( (*p) >= 9 )
		goto st4;
	goto st0;
st4:
	if ( ++p == pe )
		goto _test_eof4;
case 4:
	switch( (*p) ) {
		case 0: goto st4;
		case 13: goto st4;
		case 32: goto st4;
	}
	if ( 9 <= (*p) && (*p) <= 10 )
		goto st4;
	goto st0;
	}
	_test_eof2: cs = 2; goto _test_eof; 
	_test_eof3: cs = 3; goto _test_eof; 
	_test_eof4: cs = 4; goto _test_eof; 

	_test_eof: {}
	_out: {}
	}

#line 35 "ParseInt64.rl"


    if (neg > 0) {
        val *= -1;
    }

    if (cs < ParseInt64_first_final) {
        return HS_BOOL_FALSE;
    }

    *value = val;

    return HS_BOOL_TRUE;
}

readInt.hs

{-# LANGUAGE OverloadedStrings #-}

-- A program to QuickCheck and benchmark a function used in the Warp web server
-- and elsewhere to read the Content-Length field of HTTP headers.
--
-- Compile and run as:
--    ghc -Wall -O3 --make readInt.hs -o readInt && ./readInt

import Criterion.Main
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Int (Int64)
import Foreign.Marshal.Alloc (alloca)
import Foreign.C.Types (CChar)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable, peek)

import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as B
import qualified Data.Char as C
import qualified Numeric as N
import qualified Test.QuickCheck as QC


-- This is the absolute mimimal solution. It will return garbage if the
-- imput string contains anything other than ASCI digits.
readIntOrig :: ByteString -> Integer
readIntOrig =
    S.foldl' (\x w -> x * 10 + fromIntegral w - 48) 0


-- Using Numeric.readDec which works on String, so the ByteString has to be
-- unpacked first.
readDec :: ByteString -> Integer
readDec s =
    case N.readDec (B.unpack s) of
        [] -> 0
        (x, _):_ -> x


-- No checking for non-digits. Will overflow at 2^31 on 32 bit CPUs.
readIntRaw :: ByteString -> Int
readIntRaw =
    B.foldl' (\i c -> i * 10 + C.digitToInt c) 0


-- The best solution.
readIntTC :: Integral a => ByteString -> a
readIntTC bs = fromIntegral
    $ B.foldl' (\i c -> i * 10 + C.digitToInt c) 0 $ B.takeWhile C.isDigit bs


-- Three specialisations of readIntTC.
readInt :: ByteString -> Int
readInt = readIntTC

readInt64 :: ByteString -> Int64
readInt64 = readIntTC

readInteger :: ByteString -> Integer
readInteger = readIntTC

foreign import ccall "parseInt64"
  c'parseInt64 :: Ptr CChar -> Int -> Int -> Ptr Int64 -> IO Bool

parseWith
  :: (Integral a, Storable a)
  => (Ptr CChar -> Int -> Int -> Ptr a -> IO Bool)
  -> ByteString
  -> IO a
{-# SPECIALIZE parseWith :: (Ptr CChar -> Int -> Int -> Ptr Int64 -> IO Bool) -> ByteString -> IO Int64 #-}
parseWith ffi buff =
  unsafeUseAsCStringLen buff $ \ (ptr, len) ->
    alloca $ \ val -> do
      ok <- ffi ptr 0 (fromIntegral len) val
      if ok == False
        then return 0
        else do
          val' <- peek val
          return (fromIntegral val')

-- A QuickCheck property. Test that for a number >= 0, converting it to
-- a string using show and then reading the value back with the function
-- under test returns the original value.
-- The functions under test only work on Natural numbers (the Conent-Length
-- field in a HTTP header is always >= 0) so we check the absolute value of
-- the value that QuickCheck generates for us.
prop_read_show_idempotent :: Integral a => (ByteString -> a) -> a -> Bool
prop_read_show_idempotent freader x =
    let px = abs x
    in px == freader (B.pack $ show px)


runQuickCheckTests :: IO ()
runQuickCheckTests = do
    QC.quickCheck (prop_read_show_idempotent readInt)
    QC.quickCheck (prop_read_show_idempotent readInt64)
    QC.quickCheck (prop_read_show_idempotent readInteger)


runCriterionTests :: ByteString -> IO ()
runCriterionTests number =
    defaultMain
       [ bench "readIntOrig" $ nf readIntOrig number
       , bench "readDec"     $ nf readDec number
       , bench "readRaw"     $ nf readIntRaw number
       , bench "readInt"     $ nf readInt number
       , bench "readInt64"   $ nf readInt64 number
       , bench "readInteger" $ nf readInteger number
       , bench "c'readInt64" $ nfIO (parseWith c'parseInt64 number)
       ]


main :: IO ()
main = do
    putStrLn "Quickcheck tests."
    runQuickCheckTests
    putStrLn "Criterion tests."
    runCriterionTests "1234567898765432178979128361238162386182"