Skip to content

Commit

Permalink
made a trade: speed for proof obligations...
Browse files Browse the repository at this point in the history 
...the hackery should work out. Once finished, a critical eye from a GHC
developer cannot hurt :P
  • Loading branch information
@meiersi
meiersi committed May 8, 2012
1 parent 2c8f134 commit ce10dbf
Show file tree
Hide file tree
Showing 2 changed files with 73 additions and 68 deletions.
45 changes: 22 additions & 23 deletions bench/Benchmark.hs
View file
Expand Up @@ -98,9 +98,8 @@ main = Criterion.Main.defaultMain $
-- , bench "blaze-binary: word8sSimple" $ nf (benchDecoder Blaze.word8sSimple) (Blaze.toByteString $ word8Data nRepl)
-- , bench "cereal: word8s" $ nf (decodeLazy :: L.ByteString -> Either String [Word8]) (encodeLazy $ word8Data nRepl)
, bench "binary: word8s" $ nf (Binary.decode :: L.ByteString -> [Word8]) (Binary.encode $ word8Data nRepl)
]
{-
[ bench "param-blaze-binary: string" $ nf

, bench "param-blaze-binary: string" $ nf
(benchParamDecoder ParamBlaze.string)
(Blaze.toByteString $ charData nRepl)
, bench "blaze-binary: string" $ nf
Expand All @@ -109,17 +108,17 @@ main = Criterion.Main.defaultMain $
-- , bench "blaze-binary: word8sSimple" $ nf (benchDecoder Blaze.word8sSimple) (Blaze.toByteString $ word8Data nRepl)
-- , bench "cereal: word8s" $ nf (decodeLazy :: L.ByteString -> Either String [Word8]) (encodeLazy $ word8Data nRepl)
, bench "binary: string" $ nf (Binary.decode :: L.ByteString -> String) (Binary.encode $ charData nRepl)
-}
]

, bgroup "encode"
[ benchmarks "String " id (charData nRepl)
, benchmarks "[String] " id (stringData nRepl)
, benchmarks "testValue " id (testValue nRepl)
, benchmarks "Tree Int " id (treeIntData nRepl)
, benchmarks "Seq Int " id (seqIntData nRepl)
, benchmarks "[Int] " id (intData nRepl)
]
]
-- , bgroup "encode"
-- [ benchmarks "testValue " id (testValue nRepl)
-- , benchmarks "Tree Int " id (treeIntData nRepl)
-- , benchmarks "Seq Int " id (seqIntData nRepl)
-- , benchmarks "[Int] " id (intData nRepl)
-- , benchmarks "[String] " id (stringData nRepl)
-- ]
-- ]
where
benchDecoder :: Blaze.Decoder a -> S.ByteString -> a
benchDecoder d bs = case Blaze.runDecoder d bs of
Expand All @@ -139,19 +138,19 @@ main = Criterion.Main.defaultMain $
benchmarks :: forall a b. (Binary a, Blaze.Binary a, Serialize a, NFData a)
=> String -> (b -> a) -> b -> Benchmark
benchmarks name f x = bgroup (name ++ show nRepl)
[ bgroup "decode"
[ bench "blaze-binary" $ nf (benchDecoder Blaze.decode :: S.ByteString -> a) (Blaze.toByteString $ f x)
-- , bench "blaze-binary tagged" $ whnf (L.length . renderTagged . Blaze.encode . f) x andrea
, bench "cereal" $ nf (decodeLazy :: L.ByteString -> Either String a) (encodeLazy $ f x)
, bench "binary" $ nf (Binary.decode :: L.ByteString -> a) (Binary.encode $ f x)
]
-- , bgroup "encode"
-- [ bench "blaze-binary" $ nf (L.length . Blaze.toLazyByteString . f) x
-- [ bgroup "decode"
-- [ bench "blaze-binary" $ nf (benchDecoder Blaze.decode :: S.ByteString -> a) (Blaze.toByteString $ f x)
-- -- , bench "blaze-binary tagged" $ whnf (L.length . renderTagged . Blaze.encode . f) x andrea
-- , bench "cereal" $ nf (L.length . encodeLazy . f) x
-- , bench "binary" $ nf (L.length . Binary.encode . f) x
-- , bench "cereal" $ nf (decodeLazy :: L.ByteString -> Either String a) (encodeLazy $ f x)
-- , bench "binary" $ nf (Binary.decode :: L.ByteString -> a) (Binary.encode $ f x)
-- ]
]
--, bgroup "encode"
[ bench "blaze-binary" $ nf (L.length . Blaze.toLazyByteString . f) x
-- , bench "blaze-binary tagged" $ whnf (L.length . renderTagged . Blaze.encode . f) x andrea
, bench "cereal" $ nf (L.length . encodeLazy . f) x
, bench "binary" $ nf (L.length . Binary.encode . f) x
]
--]

-- | Testing the new binary encoding format.
testNewBinary :: Blaze.Binary a => a -> IO ()
Expand Down
96 changes: 51 additions & 45 deletions src/Data/Blaze/Binary/ParamDecoding.hs
View file
Expand Up @@ -68,10 +68,15 @@ instance Exception DecodingException where
-- calling pattern, which is precompiled in contrast to the 'stg_ap_nv'
-- calling pattern.

-- Highly unsafe trick: primitive decoders are only called via an unknown call
-- and never inlined. Pattern mathcing on their result makes sure that their
-- evaluation took place. At least for the primitive ones that return unboxed
-- values.

type PrimDecoder a = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, a #)
type PrimDecoderWord = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
type PrimDecoderWord = Addr# -> (# Addr#, Word# #)
type PrimDecoderInt = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, Int# #)
type PrimDecoderChar = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, Char# #)
type PrimDecoderChar = Addr# -> (# Addr#, Char# #)
type PrimDecoderFloat = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, Float# #)
type PrimDecoderDouble = Ptr Word8 -> State# RealWorld -> (# State# RealWorld, Addr#, Double# #)

Expand Down Expand Up @@ -128,18 +133,19 @@ decodersLE !fpbuf !ipe =

{-# INLINE word #-}
word :: forall a. Storable a => (Ptr a -> IO Word) -> PrimDecoderWord
word peekAt = \ip0 s0 ->
case nextPtr ip0 of
ip1 | ip1 <= ipe -> case runIO (peekAt (castPtr ip0)) s0 of
(# s1, W# x #) -> (# s1, getPtr ip1, x #)
word peekAt = \ip0a ->
let ip0 = Ptr ip0a in
case nextPtr (castPtr ip0 :: Ptr a) of
ip1 | ip1 <= ipe -> case runIO (peekAt (castPtr ip0)) realWorld# of
(# _, W# x #) -> (# getPtr ip1, x #)
| otherwise ->
case runIO (tooFewBytes ip0) s0 of
(# s1, W# x #) -> (# s1, getPtr ip0, x #)
case runIO (tooFewBytes ip0) realWorld# of
(# _, W# x #) -> (# getPtr ip0, x #)

{-# INLINE int #-}
int :: forall a. Storable a => (Ptr a -> IO Int) -> PrimDecoderInt
int peekAt = \ip0 s0 ->
case nextPtr ip0 of
case nextPtr (castPtr ip0 :: Ptr a) of
ip1 | ip1 <= ipe -> case runIO (peekAt (castPtr ip0)) s0 of
(# s1, I# x #) -> (# s1, getPtr ip1, x #)
| otherwise ->
Expand Down Expand Up @@ -185,22 +191,22 @@ decodersLE !fpbuf !ipe =
-}

charUtf8 :: PrimDecoderChar
charUtf8 = \ip0 s0 ->
charUtf8 = \ip0a -> let ip0 = Ptr ip0a in
if ip0 < ipe then
case runIO (peek ip0) s0 of
case runIO (peek ip0) realWorld# of
(# s1, w0 #)
| w0 < 0x80 -> (# s1, getPtr (ip0 `plusPtr` 1), chr1 w0 #)
| w0 < 0x80 -> (# getPtr (ip0 `plusPtr` 1), chr1 w0 #)

| w0 < 0xe0 && ip0 `plusPtr` 2 <= ipe ->
case runIO (peekByteOff ip0 1) s1 of
(# s2, w1 #) ->
(# s2, getPtr (ip0 `plusPtr` 2), chr2 w0 w1 #)
(# getPtr (ip0 `plusPtr` 2), chr2 w0 w1 #)

| w0 < 0xf0 && ip0 `plusPtr` 3 <= ipe ->
case runIO (peekByteOff ip0 1) s1 of
(# s2, w1 #) -> case runIO (peekByteOff ip0 2) s2 of
(# s3, w2 #) ->
(# s3, getPtr (ip0 `plusPtr` 3), chr3 w0 w1 w2 #)
(# getPtr (ip0 `plusPtr` 3), chr3 w0 w1 w2 #)

| ip0 `plusPtr` 4 <= ipe ->
case runIO (peekByteOff ip0 1) s1 of
Expand All @@ -209,14 +215,14 @@ decodersLE !fpbuf !ipe =
(# s4, w3 #) ->
let x = chr4 w0 w1 w2 w3 in
if I# x <= 0x10ffff
then (# s4, getPtr (ip0 `plusPtr` 4), chr# x #)
else runIOChr ip0 (throw (DecodingException ("invalid Unicode codepoint: " ++ show (I# x)) ip0)) s4
then (# getPtr (ip0 `plusPtr` 4), chr# x #)
else runIOChr ip0 (throw (DecodingException ("invalid Unicode codepoint: " ++ show (I# x)) ip0))

| otherwise -> runIOChr ip0 (tooFewBytes ip0) s1
else runIOChr ip0 (tooFewBytes ip0) s0
| otherwise -> runIOChr ip0 (tooFewBytes ip0)
else runIOChr ip0 (tooFewBytes ip0)
where
runIOChr ip io s0 = case runIO io s0 of
(# s1, C# c #) -> (# s1, getPtr ip, c #)
runIOChr ip io = case runIO io realWorld# of
(# s1, C# c #) -> (# getPtr ip, c #)


------------------------------------------------------------------------------
Expand All @@ -226,9 +232,8 @@ decodersLE !fpbuf !ipe =
-- | One decoding step. Note that we use a 'Ptr Word8' because the
-- 'stg_ap_pnv' calling patterns is not precompiled in GHC.
type DecodeStep a =
Ptr Word8 -- ^ Next byte to read
-> State# RealWorld -- ^ World state before
-> (# State# RealWorld, Addr#, a #)
Ptr Word8 -- ^ Next byte to read
-> (# Addr#, a #)
-- ^ World state, new next byte to read, and decoded value

-- | A decoder for Haskell values.
Expand All @@ -242,43 +247,44 @@ newtype Decoder a = Decoder {
-- | Convert an 'IO' action to a 'Decoder' action.
{-# INLINE ioToDecoder #-}
ioToDecoder :: IO a -> Decoder a
ioToDecoder (IO io) = Decoder $ \_ !(Ptr ip0) s0 -> case io s0 of
(# s1, x #) -> (# s1, ip0, x #)
ioToDecoder (IO io) = Decoder $ \_ !(Ptr ip0) -> case io realWorld# of
(# _, x #) -> (# ip0, x #)

-- | A 'DecodeStep' that fails with the given message.
failStep :: String -> DecodeStep a
failStep msg ip0 s0 =
case runIO (throw (DecodingException msg ip0)) s0 of
failStep msg ip0 =
case runIO (throw (DecodingException msg ip0)) realWorld# of
-- unreachable, but makes the type checker happy.
(# s1, x #) -> (# s1, getPtr ip0, x #)
(# _, x #) -> (# getPtr ip0, x #)


-- Instances
------------

instance Functor Decoder where
fmap f = \(Decoder io) -> Decoder $ \pd ip0 s0 ->
case io pd ip0 s0 of
(# s1, ip1, x #) -> (# s1, ip1, f x #)
{-# INLINE fmap #-}
fmap = \f (Decoder io) -> Decoder $ \pd ip0 ->
case io pd ip0 of
(# ip1, x #) -> (# ip1, f x #)

instance Applicative Decoder where
{-# INLINE pure #-}
pure x = Decoder $ \_ !(Ptr ip0) s0 -> (# s0, ip0, x #)
pure x = Decoder $ \_ ip0 -> (# getPtr ip0, x #)

{-# INLINE (<*>) #-}
Decoder fIO <*> Decoder xIO = Decoder $ \pd ip0 s0 ->
case fIO pd ip0 s0 of
(# s1, ip1, f #) -> case xIO pd (Ptr ip1) s1 of
(# s2, ip2, x #) -> (# s2, ip2, f x #)
Decoder fIO <*> Decoder xIO = Decoder $ \pd ip0 ->
case fIO pd ip0 of
(# ip1, f #) -> case xIO pd (Ptr ip1) of
(# ip2, x #) -> (# ip2, f x #)

instance Monad Decoder where
{-# INLINE return #-}
return = pure

{-# INLINE (>>=) #-}
Decoder xIO >>= f = Decoder $ \pd ip0 s0 ->
case xIO pd ip0 s0 of
(# s1, ip1, x #) -> unDecoder (f x) pd (Ptr ip1) s1
Decoder xIO >>= f = Decoder $ \pd ip0 ->
case xIO pd ip0 of
(# ip1, x #) -> unDecoder (f x) pd (Ptr ip1)

{-# INLINE fail #-}
fail = Decoder . const . failStep
Expand All @@ -296,8 +302,8 @@ runDecoder p (S.PS fpbuf off len) = S.inlinePerformIO $ do
!pd = decodersLE fpbuf ipe

(`catch` (handler ip0)) $ do
x <- IO $ \s0 -> case unDecoder p pd ip0 s0 of
(# s1, _, x #) -> (# s1, x #)
x <- IO $ \s0 -> case unDecoder p pd ip0 of
(# _, x #) -> (# s0, x #)
return (Right x)
where
handler :: Ptr Word8 -> DecodingException -> IO (Either String a)
Expand Down Expand Up @@ -332,8 +338,8 @@ prim = error "PDecoder: prim - implement"
--------------------

word8 :: Decoder Word8
word8 = Decoder $ \pd ip0 s0 -> case pdWord8 pd ip0 s0 of
(# s1, ip1, w #) -> (# s1, ip1, W8# w #)
word8 = Decoder $ \pd !(Ptr ip0) -> case pdWord8 pd ip0 of
(# ip1, w #) -> (# ip1, W8# w #)

word8s = decodeList word8

Expand Down Expand Up @@ -401,8 +407,8 @@ byteString = \len -> prim (`pdByteString` len)
-}

char :: Decoder Char
char = Decoder $ \pd ip0 s0 -> case pdChar pd ip0 s0 of
(# s1, ip1, x #) -> (# s1, ip1, C# x #)
char = Decoder $ \pd ip0 -> case pdChar pd (getPtr ip0) of
(# ip1, x #) -> (# ip1, C# x #)

{-# INLINE getAddr #-}
getAddr :: Ptr a -> Addr#
Expand Down

0 comments on commit ce10dbf

Please sign in to comment.