protocol-buffers 2.0.0 → 2.0.2
raw patch · 3 files changed
+337/−14 lines, 3 files
Files
- Text/ProtocolBuffers/Get.hs +324/−5
- Text/ProtocolBuffers/WireMessage.hs +12/−8
- protocol-buffers.cabal +1/−1
Text/ProtocolBuffers/Get.hs view
@@ -56,6 +56,8 @@ ,getWord16be,getWord32be,getWord64be ,getWord16le,getWord32le,getWord64le ,getWordhost,getWord16host,getWord32host,getWord64host+ --+ ,scan,decode7,decode7size,decode7unrolled ) where -- The Get monad is an instance of binary-strict's BinaryParser:@@ -69,22 +71,23 @@ -- implementation imports import Control.Monad(ap) -- instead of Functor.fmap; ap for Applicative --import Control.Monad(replicateM,(>=>)) -- XXX testing-import Data.Bits(Bits((.|.)))+import Data.Bits(Bits((.|.),(.&.)),shiftL) import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex) --import qualified Data.ByteString as S(unpack) -- XXX testing-import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO)-import qualified Data.ByteString.Unsafe as S(unsafeIndex)+import qualified Data.ByteString.Internal as S(ByteString(..),toForeignPtr,inlinePerformIO)+import qualified Data.ByteString.Unsafe as S(unsafeIndex,unsafeTake,unsafeDrop) import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,findIndex) --import qualified Data.ByteString.Lazy as L(pack) -- XXX testing import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq-import Data.Int(Int64) -- index type for L.ByteString+import Data.Int(Int32,Int64) -- index type for L.ByteString import Data.Monoid(Monoid(mempty,mappend)) -- Writer has a Monoid contraint import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state import Data.Word(Word,Word8,Word16,Word32,Word64) import Foreign.ForeignPtr(withForeignPtr)-import Foreign.Ptr(castPtr,plusPtr)+import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr) import Foreign.Storable(Storable(peek,sizeOf))+import System.IO.Unsafe(unsafePerformIO) #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base(Int(..),uncheckedShiftL#) import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#)@@ -100,6 +103,322 @@ , current :: !L.ByteString , consumed :: {-# UNPACK #-} !Int64 } deriving Show+++data T s = T {-# UNPACK #-} !Int s++-- | A stateful scanner. The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each byte of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail. It will return an empty string if the+-- predicate returns 'Nothing' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs. Careless use will thus result in an infinite loop.+scan :: s -> (s -> Word8 -> Maybe s) -> Get (S.ByteString,s)+scan s0 p = do+ (chunks,s) <- go [] s0+ case chunks of+ [x] -> return (x,s)+ xs -> return (S.concat . reverse $ xs, s)+ where+ go acc s1 = do+ let scanner (S.PS fp off len) =+ withForeignPtr fp $ \ptr0 -> do+ let start = ptr0 `plusPtr` off+ end = start `plusPtr` len+ inner ptr !s+ | ptr < end = do+ w <- peek ptr+ case p s w of+ Just s' -> inner (ptr `plusPtr` 1) s'+ _ -> done (ptr `minusPtr` start) s+ | otherwise = done (ptr `minusPtr` start) s+ done !i !s = return (T i s)+ inner start s1+ (S ss bs n) <- getFull+ let T i s' = unsafePerformIO $ scanner ss+ h = S.unsafeTake i ss+ t = S.unsafeDrop i ss+ n' = n + fromIntegral i+ if S.null t+ then do+ case bs of+ L.Empty -> do+ putFull (S mempty mempty n')+ continue <- suspend+ if continue+ then go (h:acc) s'+ else return (h:acc,s')+ L.Chunk ss' bs' -> do+ putFull (S ss' bs' n')+ go (h:acc) s'+ else do+ putFull (S t bs n')+ return ((h:acc),s')+++data T3 s = T3 !Int !s !Int++--data TU s = TU'OK !s !Int | TU'DO (Get s)+data TU s = TU'OK !s !Int++{-# SPECIALIZE decode7unrolled :: Get Int64 #-}+{-# SPECIALIZE decode7unrolled :: Get Int32 #-}+{-# SPECIALIZE decode7unrolled :: Get Word64 #-}+{-# SPECIALIZE decode7unrolled :: Get Word32 #-}+{-# SPECIALIZE decode7unrolled :: Get Int #-}+{-# SPECIALIZE decode7unrolled :: Get Integer #-}+decode7unrolled :: forall s. (Num s,Integral s, Bits s) => Get s+{-# NOINLINE decode7unrolled #-}+decode7unrolled = Get $ \ sc sIn@(S ss@(S.PS fp off len) bs n) pc ->+ let (TU'OK x i) = + unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do+ let ok :: s -> Int -> IO (TU s)+ ok x0 i0 = return (TU'OK x0 i0)+ more,err :: IO (TU s)+ more = return (TU'OK 0 0) -- decode7+ err = return (TU'OK 0 (-1)) -- throwError+ {-# INLINE ok #-}+ {-# INLINE more #-}+ {-# INLINE err #-}++ let start = ptr0 `plusPtr` off :: Ptr Word8+ b'1 <- peek start+ if b'1 < 128 then ok (fromIntegral b'1) 1 else do+ let !val'1 = fromIntegral (b'1 .&. 0x7F)+ !end = start `plusPtr` len+ !ptr2 = start `plusPtr` 1 :: Ptr Word8+ if ptr2 >= end then more else do++ b'2 <- peek ptr2+ if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do+ let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7))+ !ptr3 = ptr2 `plusPtr` 1+ if ptr3 >= end then more else do++ b'3 <- peek ptr3+ if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do+ let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14))+ !ptr4 = ptr3 `plusPtr` 1+ if ptr4 >= end then more else do++ b'4 <- peek ptr4+ if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do+ let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21))+ !ptr5 = ptr4 `plusPtr` 1+ if ptr5 >= end then more else do++ b'5 <- peek ptr5+ if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do+ let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28))+ !ptr6 = ptr5 `plusPtr` 1+ if ptr6 >= end then more else do+ + b'6 <- peek ptr6+ if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do+ let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35))+ !ptr7 = ptr6 `plusPtr` 1+ if ptr7 >= end then more else do+ + b'7 <- peek ptr7+ if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do+ let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42))+ !ptr8 = ptr7 `plusPtr` 1+ if ptr8 >= end then more else do+ + b'8 <- peek ptr8+ if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do+ let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49))+ !ptr9 = ptr8 `plusPtr` 1+ if ptr9 >= end then more else do+ + b'9 <- peek ptr9+ if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do+ let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56))+ !ptrA = ptr9 `plusPtr` 1+ if ptrA >= end then more else do++ b'A <- peek ptrA+ if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do+ err++ in if i > 0+ then let ss' = (S.unsafeDrop i ss)+ n' = n+fromIntegral i+ in case S.null ss' of+ False -> sc x (S ss' bs n') pc+ True -> case bs of+ L.Empty -> sc x (S mempty mempty n') pc+ L.Chunk ss'2 bs'2 -> sc x (S ss'2 bs'2 n') pc+ else if i==0 then unGet decode7 sc sIn pc+ else unGet (throwError $ "Text.ProtocolBuffers.Get.decode7unrolled: more than 10 bytes needed at bytes read of "++show n) sc sIn pc++{- used up till bench-024+decode7unrolled = Get $ \ sc sIn@(S ss@(S.PS fp off len) bs n) pc ->+ let r = unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do+ let ok :: s -> Int -> IO (TU s)+ ok x i = return (TU'OK x i)+ bad :: Get s -> IO (TU s)+ bad y = return (TU'DO y)+ let start = ptr0 `plusPtr` off :: Ptr Word8+ b'1 <- peek start+ if b'1 < 128 then ok (fromIntegral b'1) 1 else do+ let !val'1 = fromIntegral (b'1 .&. 0x7F)+ !end = start `plusPtr` len+ !ptr2 = start `plusPtr` 1 :: Ptr Word8+ if ptr2 >= end then bad decode7 else do++ b'2 <- peek ptr2+ if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do+ let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7))+ !ptr3 = ptr2 `plusPtr` 1+ if ptr3 >= end then bad decode7 else do++ b'3 <- peek ptr3+ if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do+ let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14))+ !ptr4 = ptr3 `plusPtr` 1+ if ptr4 >= end then bad decode7 else do++ b'4 <- peek ptr4+ if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do+ let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21))+ !ptr5 = ptr4 `plusPtr` 1+ if ptr5 >= end then bad decode7 else do++ b'5 <- peek ptr5+ if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do+ let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28))+ !ptr6 = ptr5 `plusPtr` 1+ if ptr6 >= end then bad decode7 else do+ + b'6 <- peek ptr6+ if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do+ let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35))+ !ptr7 = ptr6 `plusPtr` 1+ if ptr7 >= end then bad decode7 else do+ + b'7 <- peek ptr7+ if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do+ let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42))+ !ptr8 = ptr7 `plusPtr` 1+ if ptr8 >= end then bad decode7 else do+ + b'8 <- peek ptr8+ if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do+ let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49))+ !ptr9 = ptr8 `plusPtr` 1+ if ptr9 >= end then bad decode7 else do+ + b'9 <- peek ptr9+ if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do+ let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56))+ !ptrA = ptr9 `plusPtr` 1+ if ptrA >= end then bad decode7 else do++ b'A <- peek ptrA+ if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do++ bad (throwError $ "Text.ProtocolBuffers.Get.decode7unrolled: more than 10 bytes needed at bytes read of "++show n)+ in case r of+ TU'OK x i -> let ss' = (S.unsafeDrop i ss)+ n' = n+fromIntegral i+ in case S.null ss' of+ False -> sc x (S ss' bs n') pc+ True -> case bs of+ L.Empty -> sc x (S mempty mempty n') pc+ L.Chunk ss'2 bs'2 -> sc x (S ss'2 bs'2 n') pc+ TU'DO y -> unGet y sc sIn pc+-}+{-# SPECIALIZE decode7 :: Get Int64 #-}+{-# SPECIALIZE decode7 :: Get Int32 #-}+{-# SPECIALIZE decode7 :: Get Word64 #-}+{-# SPECIALIZE decode7 :: Get Word32 #-}+{-# SPECIALIZE decode7 :: Get Int #-}+{-# SPECIALIZE decode7 :: Get Integer #-}+decode7 :: forall s. (Integral s, Bits s) => Get s+{-# NOINLINE decode7 #-}+decode7 = go 0 0+ where+ go !s1 !shift1 = do+ let scanner (S.PS fp off len) =+ withForeignPtr fp $ \ptr0 -> do+ let start = ptr0 `plusPtr` off+ end = start `plusPtr` len+ inner :: (Ptr Word8) -> s -> Int -> IO (T3 s)+ inner !ptr !s !shift+ | ptr < end = do+ w <- peek ptr+ if (128>) w+ then return $ T3 (succ (ptr `minusPtr` start) )+ (s .|. ((fromIntegral w) `shiftL` shift))+ (-1) -- negative shift indicates satisfied+ else inner (ptr `plusPtr` 1) (s .|. ((fromIntegral (w .&. 0x7F)) `shiftL` shift)) (shift+7)+ | otherwise = return $ T3 (ptr `minusPtr` start) s shift+ inner start s1 shift1+ (S ss bs n) <- getFull+ let (T3 i sOut shiftOut) = unsafePerformIO $ scanner ss+ t = S.unsafeDrop i ss+ n' = n + fromIntegral i+ if 0 <= shiftOut+ then do+ case bs of+ L.Empty -> do+ putFull (S mempty mempty n')+ continue <- suspend+ if continue+ then go sOut shiftOut+ else return sOut+ L.Chunk ss' bs' -> do+ putFull (S ss' bs' n')+ go sOut shiftOut+ else do+ putFull (S t bs n')+ return sOut++data T2 = T2 !Int64 !Bool++decode7size :: Get Int64+decode7size = go 0+ where+ go !len1 = do+ let scanner (S.PS fp off len) =+ withForeignPtr fp $ \ptr0 -> do+ let start = ptr0 `plusPtr` off+ end = start `plusPtr` len+ inner :: (Ptr Word8) -> IO T2+ inner !ptr+ | ptr < end = do+ w <- peek ptr+ if (128>) w+ then return $ T2 (fromIntegral (ptr `minusPtr` start)) True+ else inner (ptr `plusPtr` 1)+ | otherwise = return $ T2 (fromIntegral (ptr `minusPtr` start)) False+ inner start+ (S ss bs n) <- getFull+ let (T2 i ok) = unsafePerformIO $ scanner ss+ t = S.unsafeDrop (fromIntegral i) ss+ n' = n + i+ len2 = len1 + i+ if ok+ then do+ putFull (S t bs n')+ return len2+ else do+ case bs of+ L.Empty -> do+ putFull (S mempty mempty n')+ continue <- suspend+ if continue+ then go len2+ else return len2+ L.Chunk ss' bs' -> do+ putFull (S ss' bs' n')+ go len2 -- Private Internal error handling stack type -- This must NOT be exposed by this module
Text/ProtocolBuffers/WireMessage.hs view
@@ -61,7 +61,7 @@ import Data.Binary.Put (Put,runPut,putWord8,putWord32le,putWord64le,putLazyByteString) import Text.ProtocolBuffers.Basic-import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,runGetAll,bytesRead,isReallyEmpty+import Text.ProtocolBuffers.Get as Get (Result(..),Get,runGet,runGetAll,bytesRead,isReallyEmpty,decode7,decode7unrolled ,spanOf,skip,lookAhead,highBitRun -- ,getByteString ,getWord8,getWord32le,getWord64le,getLazyByteString) import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo)@@ -547,14 +547,15 @@ wireSize {- TYPE_BOOL -} 8 _ = 1 wireSize ft x = wireSizeErr ft x wirePut {- TYPE_BOOL -} 8 False = putWord8 0- wirePut {- TYPE_BOOL -} 8 True = putWord8 1 -- google's wire_format_inl.h+ wirePut {- TYPE_BOOL -} 8 True = putWord8 1 -- google's wire_format_lite_inl.h wirePut ft x = wirePutErr ft x wireGet {- TYPE_BOOL -} 8 = do- x <- getVarInt :: Get Int32 -- google's wire_format_inl.h line 97+ x <- getVarInt :: Get Int32 -- google's wire_format_lit_inl.h line 155 case x of 0 -> return False- x' | x' < 128 -> return True- _ -> throwError ("TYPE_BOOL read failure : " ++ show x)+ _ -> return True+-- x' | x' < 128 -> return True+-- _ -> throwError ("TYPE_BOOL read failure : " ++ show x) wireGet ft = wireGetErr ft wireGetPacked 8 = genericPacked 8 wireGetPacked ft = wireGetErr ft@@ -630,7 +631,7 @@ zzDecode64 :: Word64 -> Int64 zzDecode64 w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1))) -{-+ -- The above is tricky, so the testing roundtrips and versus examples is needed: testZZ :: Bool testZZ = and (concat testsZZ)@@ -648,10 +649,12 @@ ] ] values :: (Bounded a,Integral a) => [a] values = [minBound,div minBound 2,-3,-2,-1,0,1,2,3,div maxBound 2, maxBound]--} -{-# INLINE getVarInt #-}+ getVarInt :: (Integral a, Bits a) => Get a+{-# INLINE getVarInt #-}+getVarInt = decode7unrolled -- decode7 -- getVarInt below+{- getVarInt = do -- optimize first read instead of calling (go 0 0) b <- getWord8 if testBit b 7 then go 7 (fromIntegral (b .&. 0x7F))@@ -661,6 +664,7 @@ b <- getWord8 if testBit b 7 then go (n+7) (val .|. ((fromIntegral (b .&. 0x7F)) `shiftL` n)) else return (val .|. ((fromIntegral b) `shiftL` n))+-} -- This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below. -- This has been changed to handle only up to 64 bit integral values (to match documentation).
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name: protocol-buffers-version: 2.0.0+version: 2.0.2 cabal-version: >= 1.6 build-type: Simple license: BSD3