protocol-buffers 2.0.7 → 2.0.8
raw patch · 2 files changed
+165/−132 lines, 2 files
Files
- Text/ProtocolBuffers/Get.hs +164/−131
- protocol-buffers.cabal +1/−1
Text/ProtocolBuffers/Get.hs view
@@ -57,7 +57,8 @@ ,getWord16le,getWord32le,getWord64le ,getWordhost,getWord16host,getWord32host,getWord64host --- ,scan,decode7,decode7size,decode7unrolled+ -- ,scan+ ,decode7,decode7size,decode7unrolled ) where -- The Get monad is an instance of binary-strict's BinaryParser:@@ -76,7 +77,7 @@ import Data.Bits(Bits((.|.),(.&.)),shiftL) import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex) import qualified Data.ByteString.Internal as S(ByteString(..),toForeignPtr,inlinePerformIO)-import qualified Data.ByteString.Unsafe as S(unsafeIndex,unsafeTake,unsafeDrop)+import qualified Data.ByteString.Unsafe as S(unsafeIndex,unsafeDrop {-,unsafeTake-}) import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,findIndex) import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq@@ -99,12 +100,13 @@ | Partial (Maybe L.ByteString -> Result a) -- Internal state type, not exposed to the user.+-- top is mempty implies current is also mempty data S = S { top :: {-# UNPACK #-} !S.ByteString , current :: !L.ByteString , consumed :: {-# UNPACK #-} !Int64 } deriving Show -+{- data T s = T {-# UNPACK #-} !Int s -- | A stateful scanner. The predicate consumes and transforms a@@ -128,6 +130,7 @@ go acc s1 = do let scanner (S.PS fp off len) = withForeignPtr fp $ \ptr0 -> do+ if ptr0 == nullPtr || len < 1 then error "Get.scan: ByteString invariant failed" else do let start = ptr0 `plusPtr` off end = start `plusPtr` len inner ptr !s@@ -160,7 +163,7 @@ 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)@@ -175,90 +178,94 @@ 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 #-}+ if ss == mempty+ then unGet decode7 sc sIn pc+ else+ let (TU'OK x i) = + unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do+ if ptr0 == nullPtr || len < 1 then error "Get.decode7unrolled: ByteString invariant failed" else 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 #-} - -- Next line is segfault fix for null bytestrings from Nathan Howell <nhowell@alphaheavy.com>- if ptr0 == nullPtr then more else do+-- -- Next line is segfault fix for null bytestrings from Nathan Howell <nhowell@alphaheavy.com>+-- if ptr0 == nullPtr then more else do - 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+ 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'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'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'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'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+ 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+ 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 ->@@ -350,6 +357,7 @@ go !s1 !shift1 = do let scanner (S.PS fp off len) = withForeignPtr fp $ \ptr0 -> do+ if ptr0 == nullPtr || len < 1 then error "Get.decode7: ByteString invariant failed" else do let start = ptr0 `plusPtr` off end = start `plusPtr` len inner :: (Ptr Word8) -> s -> Int -> IO (T3 s)@@ -364,24 +372,31 @@ | 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+ if ss == mempty 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+ continue <- suspend+ if continue+ then go 0 0+ else fail "Get.decode7: Zero length input" else do- putFull (S t bs n')- return sOut+ 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 @@ -391,6 +406,7 @@ go !len1 = do let scanner (S.PS fp off len) = withForeignPtr fp $ \ptr0 -> do+ if ptr0 == nullPtr || len < 1 then error "Get.decode7size: ByteString invariant failed" else do let start = ptr0 `plusPtr` off end = start `plusPtr` len inner :: (Ptr Word8) -> IO T2@@ -403,25 +419,32 @@ | 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+ if ss == mempty then do- putFull (S t bs n')- return len2+ continue <- suspend+ if continue+ then go 0+ else fail "Get.decode7size: zero length input" 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+ 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@@ -605,11 +628,14 @@ ensureBytes :: Int64 -> Get () ensureBytes n = do (S ss bs _read) <- getFull- if n < fromIntegral (S.length ss)- then return ()- else do if n == L.length (L.take n (L.chunk ss bs))- then return ()- else suspendMsg "ensureBytes failed" >> ensureBytes n+ if ss == mempty+ then suspendMsg "ensureBytes failed" >> ensureBytes n+ else do+ if n < fromIntegral (S.length ss)+ then return ()+ else do if n == L.length (L.take n (L.chunk ss bs))+ then return ()+ else suspendMsg "ensureBytes failed" >> ensureBytes n {-# INLINE ensureBytes #-} -- | Pull @n@ bytes from the unput, as a lazy ByteString. This will@@ -618,13 +644,16 @@ getLazyByteString n | n<=0 = return mempty | otherwise = do (S ss bs offset) <- getFull- case splitAtOrDie n (L.chunk ss bs) of- Just (consume,rest) ->do- case rest of- L.Empty -> putFull (S mempty mempty (offset + n))- L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n))- return $! consume- Nothing -> suspendMsg ("getLazyByteString failed with "++show (n,(S.length ss,L.length bs,offset))) >> getLazyByteString n+ if ss == mempty+ then suspendMsg ("getLazyByteString failed with "++show (n,(S.length ss,L.length bs,offset))) >> getLazyByteString n+ else do+ case splitAtOrDie n (L.chunk ss bs) of+ Just (consume,rest) ->do+ case rest of+ L.Empty -> putFull (S mempty mempty (offset + n))+ L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n))+ return $! consume+ Nothing -> suspendMsg ("getLazyByteString failed with "++show (n,(S.length ss,L.length bs,offset))) >> getLazyByteString n {-# INLINE getLazyByteString #-} -- important -- | 'suspend' is supposed to allow the execution of the monad to be@@ -719,7 +748,8 @@ | otherwise = do ensureBytes m (S ss bs n) <- getFull- case L.drop m (L.chunk ss bs) of+ -- Could ignore impossible ss == mempty case due to (ensureBytes m) and (0 < m)+ case L.drop m (if ss == mempty then bs else L.chunk ss bs) of L.Empty -> putFull (S mempty mempty (n+m)) L.Chunk ss' bs' -> putFull (S ss' bs' (n+m)) @@ -769,6 +799,7 @@ {-# INLINE loop #-} loop = do (S ss bs _n) <- getFull+ -- mempty is okay, will lead to Nothing below let mi = S.findIndex (128>) ss case mi of Just i -> return (succ $ fromIntegral i)@@ -779,12 +810,12 @@ Nothing -> do continue <- suspend if continue then loop- else throwError "highBitRun has failed"+ else fail "highBitRun has failed" -- | get the longest prefix of the input where all the bytes satisfy the predicate. spanOf :: (Word8 -> Bool) -> Get (L.ByteString) spanOf f = do let loop = do (S ss bs n) <- getFull- let (pre,post) = L.span f (L.chunk ss bs)+ let (pre,post) = L.span f (if ss==mempty then bs else L.chunk ss bs) case post of L.Empty -> putFull (S mempty mempty (n + L.length pre)) L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre))@@ -805,7 +836,7 @@ getByteString nIn | nIn <= 0 = return mempty | otherwise = do (S ss bs n) <- getFull- if nIn < S.length ss+ if nIn < S.length ss -- Leave at least one character of 'ss' in 'post' then do let (pre,post) = S.splitAt nIn ss putFull (S post bs (n+fromIntegral nIn)) return $! pre@@ -956,8 +987,8 @@ splitAtOrDie i ps | i <= 0 = Just (L.Empty, ps) splitAtOrDie _i L.Empty = Nothing splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x- in Just (L.Chunk pre L.Empty- ,L.Chunk post xs)+ in Just (if pre == mempty then L.Empty else L.Chunk pre L.Empty+ ,if post == mempty then xs else L.Chunk post xs) | otherwise = case splitAtOrDie (i-len) xs of Nothing -> Nothing Just (y1,y2) -> Just (L.Chunk x y1,y2)@@ -971,6 +1002,7 @@ -- underlying lazy byteString. So many indirections from the raw parser -- state that my head hurts... +-- Assume n>0 getPtr :: (Storable a) => Int -> Get a getPtr n = do (fp,o,_) <- fmap S.toForeignPtr (getByteString n)@@ -978,6 +1010,7 @@ {-# INLINE getPtr #-} -- I pushed the sizeOf into here (uses ScopedTypeVariables)+-- Assume sizeOf (undefined :: a)) > 0 getStorable :: forall a. (Storable a) => Get a getStorable = do (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a)))
protocol-buffers.cabal view
@@ -1,5 +1,5 @@ name: protocol-buffers-version: 2.0.7+version: 2.0.8 cabal-version: >= 1.6 build-type: Simple license: BSD3