diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.2.0 + - Encode protobuf wire messages in reverse order to improve perfomance + - Miscellaneous maintenance changes diff --git a/proto3-wire.cabal b/proto3-wire.cabal --- a/proto3-wire.cabal +++ b/proto3-wire.cabal @@ -1,5 +1,5 @@ name: proto3-wire -version: 1.1.0 +version: 1.2.0 synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format license: Apache-2.0 license-file: LICENSE @@ -9,6 +9,7 @@ category: Codec build-type: Simple cabal-version: >=1.10 +extra-source-files: CHANGELOG.md library exposed-modules: Proto3.Wire @@ -16,22 +17,35 @@ Proto3.Wire.Class Proto3.Wire.Decode Proto3.Wire.Encode + Proto3.Wire.Reverse + Proto3.Wire.Reverse.Prim Proto3.Wire.Tutorial Proto3.Wire.Types - build-depends: base >=4.9 && <=5.0, + other-modules: Proto3.Wire.Reverse.Internal + Proto3.Wire.Reverse.Width + build-depends: base >=4.12 && <=5.0, bytestring >=0.10.6.0 && <0.11.0, cereal >= 0.5.1 && <0.6, containers >=0.5 && < 0.7, deepseq ==1.4.*, - hashable <1.3, + ghc-prim >=0.5.3 && <0.7, + hashable <1.4, + parameterized >=0.5.0.0 && <1, + primitive >=0.6.4 && <0.8, safe ==0.3.*, text >= 0.2 && <1.3, + transformers >=0.5.6.2 && <0.6, unordered-containers >= 0.1.0.0 && <0.3, + vector >=0.12.0.2 && <0.13, QuickCheck >=2.8 && <3.0 hs-source-dirs: src default-language: Haskell2010 - ghc-options: -O2 -Wall + ghc-options: -O2 -Wall -fobject-code + -- Add any other architectures on which an unaligned poke of a multibyte + -- value would succeed and be faster than writing the bytes one by one. + if arch(x86_64) || arch(i386) + cpp-options: -DUNALIGNED_POKES test-suite tests type: exitcode-stdio-1.0 @@ -41,10 +55,12 @@ build-depends: base >=4.9 && <=5.0, bytestring >=0.10.6.0 && <0.11.0, cereal >= 0.5.1 && <0.6, - doctest >= 0.7.0 && <0.17, + doctest >= 0.7.0 && <0.18, proto3-wire, QuickCheck >=2.8 && <3.0, tasty >= 0.11 && <1.3, tasty-hunit >= 0.9 && <0.11, tasty-quickcheck >= 0.8.4 && <0.11, - text >= 0.2 && <1.3 + text >= 0.2 && <1.3, + transformers >=0.5.6.2 && <0.6, + vector >=0.12.0.2 && <0.13 diff --git a/src/Proto3/Wire/Builder.hs b/src/Proto3/Wire/Builder.hs --- a/src/Proto3/Wire/Builder.hs +++ b/src/Proto3/Wire/Builder.hs @@ -26,6 +26,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Proto3.Wire.Builder + {-# DEPRECATED "This module is no longer used by the rest of the proto3-wire package." #-} ( -- * `Builder` type Builder @@ -78,13 +79,13 @@ import qualified Data.ByteString.Short as BS import Data.Char ( ord ) import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.Semigroup ( Semigroup(..), Sum(..) ) +import Data.Semigroup ( Sum(..) ) import Data.Word ( Word8, Word16, Word32, Word64 ) import System.IO ( Handle ) -- $setup --- >>> :set -XOverloadedStrings --- >>> import Data.Semigroup +-- >>> :set -XOverloadedStrings -Wno-warnings-deprecations +-- >>> :module Proto3.Wire.Builder -- | A `Builder` is like a @"Data.ByteString.Builder".`BB.Builder`@, but also -- memoizes the resulting length so that we can efficiently encode nested diff --git a/src/Proto3/Wire/Decode.hs b/src/Proto3/Wire/Decode.hs --- a/src/Proto3/Wire/Decode.hs +++ b/src/Proto3/Wire/Decode.hs @@ -72,6 +72,8 @@ , repeated , embedded , embedded' + -- * Exported For Doctest Only + , toMap ) where import Control.Applicative @@ -97,6 +99,10 @@ import Proto3.Wire.Class import Proto3.Wire.Types +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :module Proto3.Wire.Decode Proto3.Wire.Types + -- | Decode a zigzag-encoded numeric type. -- See: http://stackoverflow.com/questions/2210923/zig-zag-decoding zigZagDecode :: (Num a, Bits a) => a -> a @@ -122,6 +128,7 @@ toMap :: [(FieldNumber, v)] -> M.IntMap [v] toMap kvs0 = M.fromListWith (<>) . map (fmap (:[])) . map (first (fromIntegral . getFieldNumber)) $ kvs0 +-- | Parses data in the raw wire format into an untyped 'Map' representation. decodeWire :: B.ByteString -> Either String [(FieldNumber, ParsedField)] decodeWire bstr = drloop bstr [] where diff --git a/src/Proto3/Wire/Encode.hs b/src/Proto3/Wire/Encode.hs --- a/src/Proto3/Wire/Encode.hs +++ b/src/Proto3/Wire/Encode.hs @@ -38,14 +38,24 @@ -- > 1 `strings` Just "some string" <> -- > 2 `strings` [ "foo", "bar", "baz" ] +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Proto3.Wire.Encode ( -- * `MessageBuilder` type MessageBuilder + , reverseMessageBuilder + , vectorMessageBuilder , messageLength - , sizedMessageBuilder - , rawMessageBuilder , toLazyByteString , unsafeFromLazyByteString @@ -77,30 +87,38 @@ , embedded -- * Packed repeated fields , packedVarints + , packedVarintsV + , packedBoolsV , packedFixed32 + , packedFixed32V , packedFixed64 + , packedFixed64V , packedFloats + , packedFloatsV , packedDoubles + , packedDoublesV ) where import Data.Bits ( (.|.), shiftL, shiftR, xor ) import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL +import Data.Coerce ( coerce ) import Data.Int ( Int32, Int64 ) -import Data.Monoid ( (<>) ) -import Data.Semigroup ( Semigroup ) -import qualified Data.Text.Encoding as Text.Encoding import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Text.Lazy.Encoding as Text.Lazy.Encoding +import Data.Vector.Generic ( Vector ) import Data.Word ( Word8, Word32, Word64 ) -import qualified Proto3.Wire.Builder as WB +import GHC.TypeLits ( KnownNat, Nat, type (+) ) +import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..), + (&<>) ) +import Parameterized.Data.Monoid ( PMEmpty(..) ) +import qualified Proto3.Wire.Reverse as RB +import qualified Proto3.Wire.Reverse.Prim as Prim import Proto3.Wire.Class import Proto3.Wire.Types -- $setup --- --- >>> :set -XOverloadedStrings +-- >>> :set -XOverloadedStrings -XOverloadedLists +-- >>> :module Proto3.Wire.Encode Proto3.Wire.Class Data.Word -- | A `MessageBuilder` represents a serialized protobuf message -- @@ -110,8 +128,8 @@ -- `MessageBuilder` -- -- Use `toLazyByteString` when you're done assembling the `MessageBuilder` -newtype MessageBuilder = MessageBuilder { unMessageBuilder :: WB.Builder } - deriving (Semigroup, Monoid) +newtype MessageBuilder = MessageBuilder { unMessageBuilder :: RB.BuildR } + deriving (Monoid, Semigroup) instance Show MessageBuilder where showsPrec prec builder = @@ -120,21 +138,30 @@ where bytes' = toLazyByteString builder --- | Retrieve the length of a message, in bytes -messageLength :: MessageBuilder -> Word -messageLength = WB.builderLength . unMessageBuilder +-- | Convert a message builder to a 'RB.BuildR'. +reverseMessageBuilder :: MessageBuilder -> RB.BuildR +reverseMessageBuilder = unMessageBuilder --- | Convert a message to a @"Proto3.Wire.Builder".`WB.Builder`@ -sizedMessageBuilder :: MessageBuilder -> WB.Builder -sizedMessageBuilder = unMessageBuilder +-- | Eta-expands a function that produces a 'MessageBuilder', so that +-- its input is not evaluated until the builder state is presented. +-- +-- This odd combinator seems to help performance at times, though +-- it may change behavior on nonterminating values of type @a@. +etaMessageBuilder :: forall a . (a -> MessageBuilder) -> a -> MessageBuilder +etaMessageBuilder = coerce (RB.etaBuildR @a) --- | Convert a message to a @"Data.ByteString.Builder".`BB.Builder`@ -rawMessageBuilder :: MessageBuilder -> BB.Builder -rawMessageBuilder = WB.rawBuilder . unMessageBuilder +-- | Essentially 'foldMap', but iterates right to left for efficiency. +vectorMessageBuilder :: + forall v a . Vector v a => (a -> MessageBuilder) -> v a -> MessageBuilder +vectorMessageBuilder = coerce (RB.vectorBuildR @v @a) +-- | O(n): Retrieve the length of a message, in bytes. +messageLength :: MessageBuilder -> Word +messageLength = fromIntegral . fst . RB.runBuildR . unMessageBuilder + -- | Convert a message to a lazy `BL.ByteString` toLazyByteString :: MessageBuilder -> BL.ByteString -toLazyByteString = WB.toLazyByteString . unMessageBuilder +toLazyByteString = RB.toLazyByteString . unMessageBuilder -- | This lets you cast an arbitrary `ByteString` to a `MessageBuilder`, whether -- or not the `ByteString` corresponds to a valid serialized protobuf message @@ -143,20 +170,82 @@ -- you assemble malformed protobuf `MessageBuilder`s unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder unsafeFromLazyByteString bytes' = - MessageBuilder { unMessageBuilder = WB.lazyByteString bytes' } + MessageBuilder { unMessageBuilder = RB.lazyByteString bytes' } -base128Varint :: Word64 -> MessageBuilder -base128Varint = MessageBuilder . WB.word64Base128LEVar +newtype MessageBoundedPrim w + = MessageBoundedPrim { unMessageBoundedPrim :: Prim.BoundedPrim w } +type instance PNullary MessageBoundedPrim width = MessageBoundedPrim width + +instance (w1 + w2) ~ w3 => + PSemigroup MessageBoundedPrim w1 w2 w3 + where + pmappend = coerce (pmappend @Nat @Prim.BoundedPrim) + {-# INLINE CONLIKE pmappend #-} + +instance Prim.AssocPlusNat MessageBoundedPrim u v w + where + assocLPlusNat = \p -> coerce (Prim.assocLPlusNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE assocLPlusNat #-} + + assocRPlusNat = \p -> coerce (Prim.assocRPlusNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE assocRPlusNat #-} + +instance Prim.CommPlusNat MessageBoundedPrim u v + where + commPlusNat = \p -> coerce (Prim.commPlusNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE commPlusNat #-} + +instance PMEmpty MessageBoundedPrim 0 + where + pmempty = coerce (pmempty @Nat @Prim.BoundedPrim) + {-# INLINE CONLIKE pmempty #-} + +instance Prim.Max u v ~ w => + Prim.PChoose MessageBoundedPrim u v w + where + pbool = coerce (Prim.pbool @Prim.BoundedPrim) + {-# INLINE CONLIKE pbool #-} + +instance Prim.AssocMaxNat MessageBoundedPrim u v w + where + assocLMaxNat = \p -> coerce (Prim.assocLMaxNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE assocLMaxNat #-} + + assocRMaxNat = \p -> coerce (Prim.assocRMaxNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE assocRMaxNat #-} + +instance Prim.CommMaxNat MessageBoundedPrim u v + where + commMaxNat = \p -> coerce (Prim.commMaxNat @Prim.BoundedPrim p) + {-# INLINE CONLIKE commMaxNat #-} + +liftBoundedPrim :: KnownNat w => MessageBoundedPrim w -> MessageBuilder +liftBoundedPrim (MessageBoundedPrim p) = MessageBuilder (Prim.liftBoundedPrim p) +{-# INLINE liftBoundedPrim #-} + +base128Varint32 :: Word32 -> MessageBoundedPrim 5 +base128Varint32 = MessageBoundedPrim . Prim.word32Base128LEVar +{-# INLINE base128Varint32 #-} + +base128Varint64 :: Word64 -> MessageBoundedPrim 10 +base128Varint64 = MessageBoundedPrim . Prim.word64Base128LEVar +{-# INLINE base128Varint64 #-} + +base128Varint64_inline :: Word64 -> MessageBoundedPrim 10 +base128Varint64_inline = MessageBoundedPrim . Prim.word64Base128LEVar_inline +{-# INLINE base128Varint64_inline #-} + wireType :: WireType -> Word8 wireType Varint = 0 wireType Fixed32 = 5 wireType Fixed64 = 1 wireType LengthDelimited = 2 -fieldHeader :: FieldNumber -> WireType -> MessageBuilder -fieldHeader num wt = base128Varint ((getFieldNumber num `shiftL` 3) .|. - fromIntegral (wireType wt)) +fieldHeader :: FieldNumber -> WireType -> MessageBoundedPrim 10 +fieldHeader = \num wt -> base128Varint64_inline + ((getFieldNumber num `shiftL` 3) .|. fromIntegral (wireType wt)) +{-# INLINE fieldHeader #-} -- | Encode a 32-bit "standard" integer -- @@ -164,17 +253,32 @@ -- -- >>> 1 `int32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" +-- >>> 1 `int64` (-42) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\214\255\255\255\255\255\255\255\255\SOH" +-- +-- NOTE: Protobuf encoding converts an @int32@ to a 64-bit unsigned value +-- before encoding it, not a 32-bit value (which would be more efficient). +-- +-- To quote the specification: "If you use int32 or int64 as the type for +-- a negative number, the resulting varint is always ten bytes long..." +-- int32 :: FieldNumber -> Int32 -> MessageBuilder -int32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) +int32 = \num i -> liftBoundedPrim $ + fieldHeader num Varint &<> base128Varint64 (fromIntegral i) +{-# INLINE int32 #-} -- | Encode a 64-bit "standard" integer -- -- For example: -- +-- >>> 1 `int32` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" -- >>> 1 `int64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\214\255\255\255\255\255\255\255\255\SOH" int64 :: FieldNumber -> Int64 -> MessageBuilder -int64 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) +int64 = \num i -> liftBoundedPrim $ + fieldHeader num Varint &<> base128Varint64 (fromIntegral i) +{-# INLINE int64 #-} -- | Encode a 32-bit unsigned integer -- @@ -183,7 +287,9 @@ -- >>> 1 `uint32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint32 :: FieldNumber -> Word32 -> MessageBuilder -uint32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) +uint32 = \num i -> liftBoundedPrim $ + fieldHeader num Varint &<> base128Varint32 i +{-# INLINE uint32 #-} -- | Encode a 64-bit unsigned integer -- @@ -192,7 +298,9 @@ -- >>> 1 `uint64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" uint64 :: FieldNumber -> Word64 -> MessageBuilder -uint64 num i = fieldHeader num Varint <> base128Varint i +uint64 = \num i -> liftBoundedPrim $ + fieldHeader num Varint &<> base128Varint64 i +{-# INLINE uint64 #-} -- | Encode a 32-bit signed integer -- @@ -200,8 +308,14 @@ -- -- >>> 1 `sint32` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS" +-- >>> 1 `sint32` maxBound +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\254\255\255\255\SI" +-- >>> 1 `sint32` minBound +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\SI" sint32 :: FieldNumber -> Int32 -> MessageBuilder -sint32 num i = int32 num ((i `shiftL` 1) `xor` (i `shiftR` 31)) +sint32 = \num i -> + uint32 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 31))) +{-# INLINE sint32 #-} -- | Encode a 64-bit signed integer -- @@ -209,8 +323,14 @@ -- -- >>> 1 `sint64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS" +-- >>> 1 `sint64` maxBound +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\254\255\255\255\255\255\255\255\255\SOH" +-- >>> 1 `sint64` minBound +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\255\255\255\255\255\255\255\255\255\SOH" sint64 :: FieldNumber -> Int64 -> MessageBuilder -sint64 num i = int64 num ((i `shiftL` 1) `xor` (i `shiftR` 63)) +sint64 = \num i -> + uint64 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 63))) +{-# INLINE sint64 #-} -- | Encode a fixed-width 32-bit integer -- @@ -219,7 +339,10 @@ -- >>> 1 `fixed32` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r*\NUL\NUL\NUL" fixed32 :: FieldNumber -> Word32 -> MessageBuilder -fixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.word32LE i) +fixed32 = \num i -> liftBoundedPrim $ + fieldHeader num Fixed32 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.word32LE i)) +{-# INLINE fixed32 #-} -- | Encode a fixed-width 64-bit integer -- @@ -228,7 +351,10 @@ -- >>> 1 `fixed64` 42 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t*\NUL\NUL\NUL\NUL\NUL\NUL\NUL" fixed64 :: FieldNumber -> Word64 -> MessageBuilder -fixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.word64LE i) +fixed64 = \num i -> liftBoundedPrim $ + fieldHeader num Fixed64 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.word64LE i)) +{-# INLINE fixed64 #-} -- | Encode a fixed-width signed 32-bit integer -- @@ -236,7 +362,10 @@ -- -- > 1 `sfixed32` (-42) sfixed32 :: FieldNumber -> Int32 -> MessageBuilder -sfixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.int32LE i) +sfixed32 = \num i -> liftBoundedPrim $ + fieldHeader num Fixed32 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.int32LE i)) +{-# INLINE sfixed32 #-} -- | Encode a fixed-width signed 64-bit integer -- @@ -245,7 +374,10 @@ -- >>> 1 `sfixed64` (-42) -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\214\255\255\255\255\255\255\255" sfixed64 :: FieldNumber -> Int64 -> MessageBuilder -sfixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.int64LE i) +sfixed64 = \num i -> liftBoundedPrim $ + fieldHeader num Fixed64 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.int64LE i)) +{-# INLINE sfixed64 #-} -- | Encode a floating point number -- @@ -254,7 +386,10 @@ -- >>> 1 `float` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\r\195\245H@" float :: FieldNumber -> Float -> MessageBuilder -float num f = fieldHeader num Fixed32 <> MessageBuilder (WB.floatLE f) +float = \num f -> liftBoundedPrim $ + fieldHeader num Fixed32 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.floatLE f)) +{-# INLINE float #-} -- | Encode a double-precision number -- @@ -263,7 +398,10 @@ -- >>> 1 `double` 3.14 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\US\133\235Q\184\RS\t@" double :: FieldNumber -> Double -> MessageBuilder -double num d = fieldHeader num Fixed64 <> MessageBuilder (WB.doubleLE d) +double = \num d -> liftBoundedPrim $ + fieldHeader num Fixed64 &<> + MessageBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE d)) +{-# INLINE double #-} -- | Encode a value with an enumerable type. -- @@ -289,8 +427,10 @@ -- >>> 1 `enum` Triangle <> 2 `enum` Gap3 -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\STX\DLE\ETX" enum :: ProtoEnum e => FieldNumber -> e -> MessageBuilder -enum num e = - fieldHeader num Varint <> base128Varint (fromIntegral (fromProtoEnum e)) +enum = \num e -> liftBoundedPrim $ + fieldHeader num Varint &<> + base128Varint32 (fromIntegral @Int32 @Word32 (fromProtoEnum e)) +{-# INLINE enum #-} -- | Encode a boolean value -- @@ -299,14 +439,20 @@ -- >>> 1 `bool` True -- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH" bool :: FieldNumber -> Bool -> MessageBuilder -bool num i = fieldHeader num Varint <> base128Varint (fromIntegral (fromEnum i)) +bool = \num b -> liftBoundedPrim $ + fieldHeader num Varint &<> + MessageBoundedPrim + (Prim.liftFixedPrim (Prim.word8 (fromIntegral (fromEnum b)))) + -- Using word8 instead of a varint encoder shrinks the width bound. +{-# INLINE bool #-} -- | Encode a sequence of octets as a field of type 'bytes'. -- --- >>> 1 `bytes` (Proto3.Wire.Builder.stringUtf8 "testing") +-- >>> 1 `bytes` (Proto3.Wire.Reverse.stringUtf8 "testing") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" -bytes :: FieldNumber -> WB.Builder -> MessageBuilder +bytes :: FieldNumber -> RB.BuildR -> MessageBuilder bytes num = embedded num . MessageBuilder +{-# INLINE bytes #-} -- | Encode a UTF-8 string. -- @@ -315,7 +461,8 @@ -- >>> 1 `string` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" string :: FieldNumber -> String -> MessageBuilder -string num = embedded num . MessageBuilder . WB.stringUtf8 +string num = embedded num . MessageBuilder . RB.stringUtf8 +{-# INLINE string #-} -- | Encode lazy `Text` as UTF-8 -- @@ -324,16 +471,8 @@ -- >>> 1 `text` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder -text num txt = - embedded num (MessageBuilder (WB.unsafeMakeBuilder len (Text.Lazy.Encoding.encodeUtf8Builder txt))) - where - -- It would be nice to avoid actually allocating encoded chunks, - -- but we leave that enhancement for a future time. - len = Text.Lazy.foldrChunks op 0 txt - op chnk acc = fromIntegral (B.length (Text.Encoding.encodeUtf8 chnk)) + acc -{-# INLINABLE text #-} - -- INLINABLE so that if the input is constant, the compiler - -- has the opportunity to express its length as a CAF. +text num = embedded num . MessageBuilder . RB.lazyTextUtf8 +{-# INLINE text #-} -- | Encode a collection of bytes in the form of a strict 'B.ByteString'. -- @@ -342,7 +481,8 @@ -- >>> 1 `byteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" byteString :: FieldNumber -> B.ByteString -> MessageBuilder -byteString num bs = embedded num (MessageBuilder (WB.byteString bs)) +byteString num = embedded num . MessageBuilder . RB.byteString +{-# INLINE byteString #-} -- | Encode a lazy bytestring. -- @@ -351,43 +491,140 @@ -- >>> 1 `lazyByteString` "testing" -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder -lazyByteString num bl = embedded num (MessageBuilder (WB.lazyByteString bl)) +lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString +{-# INLINE lazyByteString #-} -- | Encode varints in the space-efficient packed format. +-- But consider 'packedVarintsV', which may be faster. -- --- >>> 1 `packedVarints` [1, 2, 3] +-- The values to be encoded are specified by mapping the elements of a vector. +-- +-- >>> packedVarints 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedVarints num = embedded num . foldMap base128Varint +packedVarints num = + etaMessageBuilder + (embedded num . foldMap (liftBoundedPrim . base128Varint64)) +{-# INLINE packedVarints #-} +-- | A faster but more specialized variant of: +-- +-- > \f num -> packedVarints num . fmap f +-- +-- >>> packedVarintsV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word64) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" +packedVarintsV :: + Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder +packedVarintsV f num = + embedded num . vectorMessageBuilder (liftBoundedPrim . base128Varint64 . f) +{-# INLINE packedVarintsV #-} + +-- | A faster but more specialized variant of: +-- +-- > packedVarintsV (fromIntegral . fromEnum) num +-- +-- >>> packedBoolsV not 1 ([False, True] :: Data.Vector.Vector Bool) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\STX\SOH\NUL" +packedBoolsV :: + Vector v a => (a -> Bool) -> FieldNumber -> v a -> MessageBuilder +packedBoolsV f num = + embedded num . MessageBuilder . Prim.vectorFixedPrim op + where + op = Prim.word8 . fromIntegral . fromEnum . f +{-# INLINE packedBoolsV #-} + -- | Encode fixed-width Word32s in the space-efficient packed format. +-- But consider 'packedFixed32V', which may be faster. -- --- >>> 1 `packedFixed32` [1, 2, 3] +-- The values to be encoded are specified by mapping the elements of a vector. +-- +-- >>> packedFixed32 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" packedFixed32 :: Foldable f => FieldNumber -> f Word32 -> MessageBuilder -packedFixed32 num = embedded num . foldMap (MessageBuilder . WB.word32LE) +packedFixed32 num = + etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word32LE)) +{-# INLINE packedFixed32 #-} +-- | A faster but more specialized variant of: +-- +-- > \f num -> packedFixed32 num . fmap f +-- +-- >>> packedFixed32V (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word32) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" +packedFixed32V :: + Vector v a => (a -> Word32) -> FieldNumber -> v a -> MessageBuilder +packedFixed32V f num = + embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word32LE . f) +{-# INLINE packedFixed32V #-} + -- | Encode fixed-width Word64s in the space-efficient packed format. +-- But consider 'packedFixed64V', which may be faster. -- --- >>> 1 `packedFixed64` [1, 2, 3] +-- The values to be encoded are specified by mapping the elements of a vector. +-- +-- >>> packedFixed64 1 [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" packedFixed64 :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder -packedFixed64 num = embedded num . foldMap (MessageBuilder . WB.word64LE) +packedFixed64 num = + etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word64LE)) +{-# INLINE packedFixed64 #-} +-- | A faster but more specialized variant of: +-- +-- > \f num -> packedFixed64 num . fmap f +-- +-- >>> packedFixed64V (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Word64) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedFixed64V :: + Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder +packedFixed64V f num = + embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word64LE . f) +{-# INLINE packedFixed64V #-} + -- | Encode floats in the space-efficient packed format. +-- But consider 'packedFloatsV', which may be faster. -- -- >>> 1 `packedFloats` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" packedFloats :: Foldable f => FieldNumber -> f Float -> MessageBuilder -packedFloats num = embedded num . foldMap (MessageBuilder . WB.floatLE) +packedFloats num = + etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.floatLE)) +{-# INLINE packedFloats #-} +-- | A faster but more specialized variant of: +-- +-- > \f num -> packedFloats num . fmap f +-- +-- >>> packedFloatsV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Float) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" +packedFloatsV :: + Vector v a => (a -> Float) -> FieldNumber -> v a -> MessageBuilder +packedFloatsV f num = + embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.floatLE . f) +{-# INLINE packedFloatsV #-} + -- | Encode doubles in the space-efficient packed format. +-- But consider 'packedDoublesV', which may be faster. -- -- >>> 1 `packedDoubles` [1, 2, 3] -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" packedDoubles :: Foldable f => FieldNumber -> f Double -> MessageBuilder -packedDoubles num = embedded num . foldMap (MessageBuilder . WB.doubleLE) +packedDoubles num = + etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.doubleLE)) +{-# INLINE packedDoubles #-} +-- | A faster but more specialized variant of: +-- +-- > \f num -> packedDoubles num . fmap f +-- +-- >>> packedDoublesV (subtract 10) 1 ([11, 12, 13] :: Data.Vector.Vector Double) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" +packedDoublesV :: + Vector v a => (a -> Double) -> FieldNumber -> v a -> MessageBuilder +packedDoublesV f num = + embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.doubleLE . f) +{-# INLINE packedDoublesV #-} + -- | Encode an embedded message. -- -- The message is represented as a 'MessageBuilder', so it is possible to chain @@ -398,6 +635,10 @@ -- >>> 1 `embedded` (1 `string` "this message" <> 2 `string` " is embedded") -- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\FS\n\fthis message\DC2\f is embedded" embedded :: FieldNumber -> MessageBuilder -> MessageBuilder -embedded num bb = fieldHeader num LengthDelimited <> - base128Varint (fromIntegral (messageLength bb)) <> - bb +embedded = \num (MessageBuilder bb) -> + MessageBuilder (RB.withLengthOf (Prim.liftBoundedPrim . prefix num) bb) + where + prefix num len = + unMessageBoundedPrim (fieldHeader num LengthDelimited) &<> + Prim.wordBase128LEVar (fromIntegral @Int @Word len) +{-# INLINE embedded #-} diff --git a/src/Proto3/Wire/Reverse.hs b/src/Proto3/Wire/Reverse.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Reverse.hs @@ -0,0 +1,792 @@ +{- + Copyright 2020 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | This module differs from the "Data.ByteString.Builder" module by +-- writing the octets in reverse order, which lets us compute the length +-- of a submessage by writing that submessage and measuring its length +-- before we write a variadic integer prefix encoding that length. +-- +-- Example use: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (withLengthOf (word64Base128LEVar . fromIntegral) (word32BE 42 <> charUtf8 'λ'))) +-- [6,0,0,0,42,206,187] + +{-# LANGUAGE BangPatterns #-} + +module Proto3.Wire.Reverse + ( -- * `BuildR` type + BuildR + + -- * Create `BuildR`s + , etaBuildR + , ensure + , withLengthOf + , byteString + , lazyByteString + , shortByteString + , word8 + , int8 + , word16BE + , word16LE + , int16BE + , int16LE + , word32BE + , word32LE + , int32BE + , int32LE + , word64BE + , word64LE + , int64BE + , int64LE + , floatBE + , floatLE + , doubleBE + , doubleLE + , char7 + , string7 + , char8 + , string8 + , charUtf8 + , stringUtf8 + , textUtf8 + , lazyTextUtf8 + , wordBase128LEVar + , wordBase128LEVar_inline + , word32Base128LEVar + , word32Base128LEVar_inline + , word64Base128LEVar + , word64Base128LEVar_inline + , vectorBuildR + + -- * Consume `BuildR`s + , runBuildR + , toLazyByteString + + -- * Helpful combinators + , foldlRVector + + -- * Exported for testing purposes only. + , testWithUnused + ) where + +import Data.Bits ( (.&.) ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BLI +import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BSI +import qualified Data.ByteString.Unsafe as BU +import Data.Char ( ord ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import qualified Data.Text as T +import qualified Data.Text.Internal as TI +import qualified Data.Text.Internal.Fusion as TIF +import qualified Data.Text.Lazy as TL +import Data.Vector.Generic ( Vector ) +import Data.Word ( Word8, Word16, Word32, Word64 ) +import Foreign ( castPtr ) +import Proto3.Wire.Reverse.Internal +import qualified Proto3.Wire.Reverse.Prim as Prim + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :module Proto3.Wire.Reverse + +-- | Create a lazy `BL.ByteString` from a `BuildR` +-- +-- > toLazyByteString (x <> y) = toLazyByteString x <> toLazyByteString y +-- > +-- > toLazyByteString mempty = mempty +-- +-- >>> toLazyByteString (stringUtf8 "ABC") +-- "ABC" +toLazyByteString :: BuildR -> BL.ByteString +toLazyByteString = snd . runBuildR + +-- | Convert a strict `B.ByteString` to a `BuildR` +-- +-- > byteString (x <> y) = byteString x <> byteString y +-- > +-- > byteString mempty = mempty +-- +-- >>> byteString "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +byteString :: B.ByteString -> BuildR +byteString bs = withUnused $ \unused -> + let len = B.length bs in + if len <= unused + then + unsafeConsume len $ \dst -> + BU.unsafeUseAsCString bs $ \src -> + BI.memcpy dst (castPtr src) len + else + prependChunk bs + +-- | Convert a lazy `BL.ByteString` to a `BuildR` +-- +-- Warning: evaluating the length will force the lazy `BL.ByteString`'s chunks, +-- and they will remain allocated until you finish using the builder. +-- +-- > lazyByteString (x <> y) = lazyByteString x <> lazyByteString y +-- > +-- > lazyByteString mempty = mempty +-- +-- > lazyByteString . toLazyByteString = id +-- > +-- > toLazyByteString . lazyByteString = id +-- +-- >>> lazyByteString "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +lazyByteString :: BL.ByteString -> BuildR +lazyByteString = etaBuildR $ scan (ReverseChunks BL.empty) + where + scan :: ReverseChunks -> BL.ByteString -> BuildR + scan r BLI.Empty = prepend r + scan (ReverseChunks r) (BLI.Chunk c cs) = + scan (ReverseChunks (BLI.Chunk c r)) cs + + prepend :: ReverseChunks -> BuildR + prepend (ReverseChunks BLI.Empty) = mempty + prepend (ReverseChunks (BLI.Chunk c cs)) = withUnused $ \unused -> + let len = B.length c in + if len <= unused + then + (prepend (ReverseChunks cs) <>) $ + unsafeConsume len $ \dst -> + BU.unsafeUseAsCString c $ \src -> + BI.memcpy dst (castPtr src) len + else + prependReverseChunks (ReverseChunks(BLI.Chunk c cs)) + +-- | Convert a `BS.ShortByteString` to a `BuildR` +-- +-- > shortByteString (x <> y) = shortByteString x <> shortByteString y +-- > +-- > shortByteString mempty = mempty +-- +-- >>> shortByteString "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +shortByteString :: BS.ShortByteString -> BuildR +shortByteString bs = withUnused $ \unused -> + let len = BS.length bs in + if len <= unused + then + writeChunk bs 0 len + else + let rest = len - unused in + writeChunk bs unused rest <> reallocate rest <> writeChunk bs 0 unused + where + writeChunk src off len = + unsafeConsume len $ \dst -> + BSI.copyToPtr src off dst len + +-- | Convert a `Word8` to a `BuildR` +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word8 42)) +-- [42] +word8 :: Word8 -> BuildR +word8 = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word8 x)) +{-# INLINE word8 #-} + +-- | Convert a `Int8` to a `BuildR` +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int8 (-5))) +-- [251] +int8 :: Int8 -> BuildR +int8 = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int8 x)) +{-# INLINE int8 #-} + +-- | Convert a `Word16` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16BE 42)) +-- [0,42] +word16BE :: Word16 -> BuildR +word16BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word16BE x)) +{-# INLINE word16BE #-} + +-- | Convert a `Word16` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16LE 42)) +-- [42,0] +word16LE :: Word16 -> BuildR +word16LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word16LE x)) +{-# INLINE word16LE #-} + +-- | Convert an `Int16` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16BE (-5))) +-- [255,251] +int16BE :: Int16 -> BuildR +int16BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int16BE x)) +{-# INLINE int16BE #-} + +-- | Convert an `Int16` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16LE (-5))) +-- [251,255] +int16LE :: Int16 -> BuildR +int16LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int16LE x)) +{-# INLINE int16LE #-} + +-- | Convert a `Word32` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32BE 42)) +-- [0,0,0,42] +word32BE :: Word32 -> BuildR +word32BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word32BE x)) +{-# INLINE word32BE #-} + +-- | Convert a `Word32` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32LE 42)) +-- [42,0,0,0] +word32LE :: Word32 -> BuildR +word32LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word32LE x)) +{-# INLINE word32LE #-} + +-- | Convert an `Int32` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32BE (-5))) +-- [255,255,255,251] +int32BE :: Int32 -> BuildR +int32BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int32BE x)) +{-# INLINE int32BE #-} + +-- | Convert an `Int32` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32LE (-5))) +-- [251,255,255,255] +int32LE :: Int32 -> BuildR +int32LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int32LE x)) +{-# INLINE int32LE #-} + +-- | Convert a `Word64` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64BE 42)) +-- [0,0,0,0,0,0,0,42] +word64BE :: Word64 -> BuildR +word64BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word64BE x)) +{-# INLINE word64BE #-} + +-- | Convert a `Word64` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64LE 42)) +-- [42,0,0,0,0,0,0,0] +word64LE :: Word64 -> BuildR +word64LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.word64LE x)) +{-# INLINE word64LE #-} + +-- | Convert an `Int64` to a `BuildR` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64BE (-5))) +-- [255,255,255,255,255,255,255,251] +int64BE :: Int64 -> BuildR +int64BE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int64BE x)) +{-# INLINE int64BE #-} + +-- | Convert an `Int64` to a `BuildR` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64LE (-5))) +-- [251,255,255,255,255,255,255,255] +int64LE :: Int64 -> BuildR +int64LE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.int64LE x)) +{-# INLINE int64LE #-} + +-- | Convert a `Float` to a `BuildR` by storing the bytes in IEEE-754 format in +-- big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatBE 4.2)) +-- [64,134,102,102] +floatBE :: Float -> BuildR +floatBE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.floatBE x)) +{-# INLINE floatBE #-} + +-- | Convert a `Float` to a `BuildR` by storing the bytes in IEEE-754 format in +-- little-endian order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatLE 4.2)) +-- [102,102,134,64] +floatLE :: Float -> BuildR +floatLE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.floatLE x)) +{-# INLINE floatLE #-} + +-- | Convert a `Double` to a `BuildR` by storing the bytes in IEEE-754 format +-- in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleBE 4.2)) +-- [64,16,204,204,204,204,204,205] +doubleBE :: Double -> BuildR +doubleBE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.doubleBE x)) +{-# INLINE doubleBE #-} + +-- | Convert a `Double` to a `BuildR` by storing the bytes in IEEE-754 format +-- in little-endian order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleLE 4.2)) +-- [205,204,204,204,204,204,16,64] +doubleLE :: Double -> BuildR +doubleLE = \x -> Prim.liftBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE x)) +{-# INLINE doubleLE #-} + +-- | Convert an @ASCII@ `Char` to a `BuildR` +-- +-- __Careful:__ If you provide a Unicode character that is not part of the +-- @ASCII@ alphabet this will only encode the lowest 7 bits +-- +-- >>> char7 ';' +-- Proto3.Wire.Reverse.lazyByteString ";" +-- >>> char7 'λ' -- Example of truncation +-- Proto3.Wire.Reverse.lazyByteString ";" +char7 :: Char -> BuildR +char7 = word8 . (0x7F .&.) . fromIntegral . ord +{-# INLINE char7 #-} + +-- | Convert an @ASCII@ `String` to a `BuildR` +-- +-- __Careful:__ If you provide a Unicode `String` that has non-@ASCII@ +-- characters then this will only encode the lowest 7 bits of each character +-- +-- > string7 (x <> y) = string7 x <> string7 y +-- > +-- > string7 mempty = mempty +-- +-- >>> string7 "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +-- >>> string7 "←↑→↓" -- Example of truncation +-- Proto3.Wire.Reverse.lazyByteString "\DLE\DC1\DC2\DC3" +string7 :: String -> BuildR +string7 = foldMap char7 + -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort. + -- Could we do better here? + +-- | Convert an @ISO/IEC 8859-1@ `Char` to a `BuildR` +-- +-- __Careful:__ If you provide a Unicode character that is not part of the +-- @ISO/IEC 8859-1@ alphabet then this will only encode the lowest 8 bits +-- +-- >>> char8 ';' +-- Proto3.Wire.Reverse.lazyByteString ";" +-- >>> char8 'λ' -- Example of truncation +-- Proto3.Wire.Reverse.lazyByteString "\187" +char8 :: Char -> BuildR +char8 = word8 . fromIntegral . ord +{-# INLINE char8 #-} + +-- | Convert an @ISO/IEC 8859-1@ `String` to a `BuildR` +-- +-- __Careful:__ If you provide a Unicode `String` that has non-@ISO/IEC 8859-1@ +-- characters then this will only encode the lowest 8 bits of each character +-- +-- > string8 (x <> y) = string8 x <> string8 y +-- > +-- > string8 mempty = mempty +-- +-- >>> string8 "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +-- >>> string8 "←↑→↓" -- Example of truncation +-- Proto3.Wire.Reverse.lazyByteString "\144\145\146\147" +string8 :: String -> BuildR +string8 = foldMap char8 + -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort. + -- Could we do better here? + +-- | Convert a Unicode `Char` to a `BuildR` using a @UTF-8@ encoding +-- +-- >>> charUtf8 'A' +-- Proto3.Wire.Reverse.lazyByteString "A" +-- >>> charUtf8 'λ' +-- Proto3.Wire.Reverse.lazyByteString "\206\187" +-- >>> charUtf8 (Data.Char.chr 0x7FF) +-- Proto3.Wire.Reverse.lazyByteString "\223\191" +-- >>> charUtf8 (Data.Char.chr 0x800) +-- Proto3.Wire.Reverse.lazyByteString "\224\160\128" +-- >>> charUtf8 (Data.Char.chr 0xFFFF) +-- Proto3.Wire.Reverse.lazyByteString "\239\191\191" +-- >>> charUtf8 (Data.Char.chr 0x10000) +-- Proto3.Wire.Reverse.lazyByteString "\240\144\128\128" +-- >>> charUtf8 (Data.Char.chr 0x10FFFF) +-- Proto3.Wire.Reverse.lazyByteString "\244\143\191\191" +charUtf8 :: Char -> BuildR +charUtf8 = \x -> Prim.liftBoundedPrim (Prim.charUtf8 x) +{-# INLINE charUtf8 #-} + +-- | Convert a Unicode `String` to a `BuildR` using a @UTF-8@ encoding +-- +-- > stringUtf8 (x <> y) = stringUtf8 x <> stringUtf8 y +-- > +-- > stringUtf8 mempty = mempty +-- +-- >>> stringUtf8 "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +-- >>> stringUtf8 "←↑→↓" +-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147" +-- >>> Data.ByteString.Lazy.hPutStr System.IO.stdout (toLazyByteString (stringUtf8 "←↑→↓\n")) +-- ←↑→↓ +stringUtf8 :: String -> BuildR +stringUtf8 = foldMap charUtf8 + -- TO DO: 'Data.ByteString.Builder' goes to considerably more effort. + -- Could we do better here? + +-- | Convert a Unicode strict `T.Text` to a `BuildR` using a @UTF-8@ encoding +-- +-- > textUtf8 (x <> y) = textUtf8 x <> textUtf8 y +-- > +-- > textUtf8 mempty = mempty +-- +-- >>> textUtf8 "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +-- >>> textUtf8 "←↑→↓" +-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147" +textUtf8 :: T.Text -> BuildR +textUtf8 = etaBuildR $ \txt@(TI.Text _ _ word16Count) -> + case TIF.reverseStream txt of + TIF.Stream next t0 _ -> ensure bound (go t0) + where + -- Any non-surrogate UTF-16 word encodes a 'Char' whose UTF-8 + -- encoding involves at most 3 octets. Any surrogate pair is + -- two UTF-16 words that give rise to 4 octets. Therefore we + -- will see at most 3 UTF-8 bytes per UTF-16 word of input. + -- + -- This is a significant overallocation in the ASCII case, + -- where we see only one UTF-8 byte per UTF-16 word of input. + -- If such overallocation becomes a problem, we could implement + -- a prescan that computes the exact size required. + -- + -- However, we anticipate that in most cases we will be + -- building from many text chunks that individually much + -- smaller than the overall size of the combined result, + -- making overallocation relatively harmless. + bound = 3 * word16Count + + go = etaBuildR $ \t1 -> case next t1 of + TIF.Done -> mempty + TIF.Skip t2 -> go t2 + TIF.Yield !ch t2 -> + go t2 <> Prim.unsafeBuildBoundedPrim (Prim.charUtf8 ch) + +-- | Convert a Unicode lazy `TL.Text` to a `BuildR` using a @UTF-8@ encoding +-- +-- > lazyTextUtf8 (x <> y) = lazyTextUtf8 x <> lazyTextUtf8 y +-- > +-- > lazyTextUtf8 mempty = mempty +-- +-- >>> lazyTextUtf8 "ABC" +-- Proto3.Wire.Reverse.lazyByteString "ABC" +-- >>> lazyTextUtf8 "←↑→↓" +-- Proto3.Wire.Reverse.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147" +lazyTextUtf8 :: TL.Text -> BuildR +lazyTextUtf8 = TL.foldrChunks ((<>) . textUtf8) mempty + +-- | Convert a `Word` to a `BuildR` using this variable-length encoding: +-- +-- 1. Convert the given value to a base 128 representation +-- without unnecessary digits (that is, omit zero digits +-- unless they are less significant than nonzero digits). +-- +-- 2. Present those base-128 digits in order of increasing +-- significance (that is, in little-endian order). +-- +-- 3. Add 128 to every digit except the most significant digit, +-- yielding a sequence of octets terminated by one that is <= 127. +-- +-- This encoding is used in the wire format of Protocol Buffers version 3. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +wordBase128LEVar :: Word -> BuildR +wordBase128LEVar = \x -> Prim.liftBoundedPrim (Prim.wordBase128LEVar x) +{-# INLINE wordBase128LEVar #-} + +-- | Like 'wordBase128LEVar' but inlined, which may bloat your code. On +-- the other hand, inlining an application to a constant may shrink your code. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (wordBase128LEVar_inline (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +wordBase128LEVar_inline :: Word -> BuildR +wordBase128LEVar_inline = \x -> + Prim.liftBoundedPrim (Prim.wordBase128LEVar_inline x) +{-# INLINE wordBase128LEVar_inline #-} + +-- | Convert a `Word32` to a `BuildR` using this variable-length encoding: +-- +-- 1. Convert the given value to a base 128 representation +-- without unnecessary digits (that is, omit zero digits +-- unless they are less significant than nonzero digits). +-- +-- 2. Present those base-128 digits in order of increasing +-- significance (that is, in little-endian order). +-- +-- 3. Add 128 to every digit except the most significant digit, +-- yielding a sequence of octets terminated by one that is <= 127. +-- +-- This encoding is used in the wire format of Protocol Buffers version 3. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +word32Base128LEVar :: Word32 -> BuildR +word32Base128LEVar = \x -> Prim.liftBoundedPrim (Prim.word32Base128LEVar x) +{-# INLINE word32Base128LEVar #-} + +-- | Like 'word32Base128LEVar' but inlined, which may bloat your code. On +-- the other hand, inlining an application to a constant may shrink your code. +-- +-- Currently 'word32Base128LEVar' is fully inline, so this makes no difference, +-- but in future we might make different default space/speed tradeoffs. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32Base128LEVar_inline (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +word32Base128LEVar_inline :: Word32 -> BuildR +word32Base128LEVar_inline = \x -> + Prim.liftBoundedPrim (Prim.word32Base128LEVar_inline x) +{-# INLINE word32Base128LEVar_inline #-} + +-- | Like 'word32Base128LEVar' but for 64-bit inputs. +-- +-- Inlines when the value fits within 32 bits, but see +-- also 'word64Base128LEVar_inline', which always inlines. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 32))) +-- [128,128,128,128,16] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 56 - 1))) +-- [255,255,255,255,255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 56))) +-- [128,128,128,128,128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 60 - 1))) +-- [255,255,255,255,255,255,255,255,15] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 60))) +-- [128,128,128,128,128,128,128,128,16] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 63 - 1))) +-- [255,255,255,255,255,255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (Data.Bits.shiftL 1 63))) +-- [128,128,128,128,128,128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar (- (1 :: Data.Word.Word64)))) +-- [255,255,255,255,255,255,255,255,255,1] +word64Base128LEVar :: Word64 -> BuildR +word64Base128LEVar = \x -> Prim.liftBoundedPrim (Prim.word64Base128LEVar x) +{-# INLINE word64Base128LEVar #-} + +-- | Like 'word64Base128LEVar' but inlined, which may bloat your code. On +-- the other hand, inlining an application to a constant may shrink your code. +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline 42)) +-- [42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline 5376)) +-- [128,42] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 7 - 1))) +-- [127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 7))) +-- [128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 14 - 1))) +-- [255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 14))) +-- [128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 21 - 1))) +-- [255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 21))) +-- [128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 28 - 1))) +-- [255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 28))) +-- [128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 32 - 1))) +-- [255,255,255,255,15] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 32))) +-- [128,128,128,128,16] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 56 - 1))) +-- [255,255,255,255,255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 56))) +-- [128,128,128,128,128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 60 - 1))) +-- [255,255,255,255,255,255,255,255,15] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 60))) +-- [128,128,128,128,128,128,128,128,16] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 63 - 1))) +-- [255,255,255,255,255,255,255,255,127] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (Data.Bits.shiftL 1 63))) +-- [128,128,128,128,128,128,128,128,128,1] +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64Base128LEVar_inline (- (1 :: Data.Word.Word64)))) +-- [255,255,255,255,255,255,255,255,255,1] +word64Base128LEVar_inline :: Word64 -> BuildR +word64Base128LEVar_inline = \x -> + Prim.liftBoundedPrim (Prim.word64Base128LEVar_inline x) +{-# INLINE word64Base128LEVar_inline #-} + +-- | Essentially 'foldMap', but iterates right to left for efficiency. +vectorBuildR :: Vector v a => (a -> BuildR) -> v a -> BuildR +vectorBuildR f = etaBuildR (foldlRVector (\acc x -> acc <> f x) mempty) +{-# INLINE vectorBuildR #-} + +-- | Exported for testing purposes only. +testWithUnused :: (Int -> BuildR) -> BuildR +testWithUnused = withUnused +{-# WARNING testWithUnused "Exported for testing purposes only." #-} diff --git a/src/Proto3/Wire/Reverse/Internal.hs b/src/Proto3/Wire/Reverse/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Reverse/Internal.hs @@ -0,0 +1,715 @@ +{- + Copyright 2020 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | Implementation details of the "Data.ByteString.Reverse" module. +-- Breaking changes will be more frequent in this module; use with caution. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Proto3.Wire.Reverse.Internal + ( BuildR(..) + , appendBuildR + , foldlRVector + , toBuildR + , fromBuildR + , etaBuildR + , runBuildR + , withUnused + , withTotal + , withLengthOf + , withLengthOf# + , reallocate + , prependChunk + , ReverseChunks(..) + , prependReverseChunks + , ensure + , ensure# + , unsafeConsume + , floatToWord32 + , doubleToWord64 + ) where + +import Control.Exception ( bracket ) +import Control.Monad.Trans.State.Strict ( State, runState, state ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Builder.Extra as BB +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BLI +import Data.IORef ( IORef, newIORef, + readIORef, writeIORef ) +import qualified Data.Primitive as P +import qualified Data.Vector.Generic as VG +import Data.Vector.Generic ( Vector ) +import Data.Word ( Word8, Word32, Word64 ) +import Foreign ( Storable(..), + castPtrToStablePtr, + castStablePtrToPtr, + freeStablePtr, newStablePtr, + deRefStablePtr ) +import GHC.Exts ( Addr#, Int#, MutVar#, + RealWorld, StablePtr#, State#, + addrToAny#, int2Addr#, + touch# ) +import GHC.ForeignPtr ( ForeignPtr(..), + ForeignPtrContents(..) ) +import GHC.IO ( IO(..) ) +import GHC.IORef ( IORef(..) ) +import GHC.Int ( Int(..) ) +import GHC.Ptr ( Ptr(..), plusPtr ) +import GHC.Stable ( StablePtr(..) ) +import GHC.STRef ( STRef(..) ) +import System.IO.Unsafe ( unsafePerformIO ) + +#if MIN_VERSION_primitive(0,7,0) +#define PTR P.Ptr +#else +#define PTR P.Addr +#endif + +-- $setup +-- >>> :set -XOverloadedStrings + +-- | Writes bytes in reverse order, updating the current state. +-- +-- It is the responsibility of the execution context and buffer +-- management primitives to ensure that the current buffer remains +-- reachable during builder execution, though completed buffers +-- may be copied to new storage at any time. Aside from those +-- primitives, 'BuildR' implementations may ignore that issue. +-- +-- When combining `BuildR`s with '<>' we expect the best performance +-- when associating to the left. For example @'foldl' ('<>') 'mempty'@, +-- though unless your 'foldl' iteration starts from the right there may +-- still be issues. Consider using `Proto3.Wire.Reverse.vectorBuildR` +-- instead of 'foldMap'. +newtype BuildR = BuildR + (Addr# -> Int# -> State# RealWorld -> (# Addr#, Int#, State# RealWorld #)) + -- ^ Both the builder arguments and the returned values are: + -- + -- 1. The starting address of the *used* portion of the current buffer. + -- + -- 2. The number of *unused* bytes in the current buffer. + -- + -- 3. The state token (which does not consume any machine registers). + -- + -- It seems we cannot preserve register allocation between the arguments + -- and the returned components, even by including padding. If GHC were to + -- allocate registers right-to-left (instead of the current left-to-right), + -- and if it made sure to allocate the register that it uses for closure + -- arguments *last* when allocating return registers, then we would stand + -- a chance of not having to move the state components between registers. + -- That way @a -> b -> 'BuildR'@ and 'BuildR' would use the same registers + -- for state components as each other, and a non-inline return from one + -- could be used to call the other without moving state components. + -- + -- But in many cases register movements combine with increments. + -- Also, we have arranged to put only the most frequently-used state + -- components into registers, which reduces the costs of both moves + -- and of save/reload pairs. For example, our tracking of the total + -- bytes written involves metadata at the start of the current buffer + -- rather than an additional state register. + +instance Semigroup BuildR + where + (<>) = appendBuildR + {-# INLINE (<>) #-} + +instance Monoid BuildR + where + mempty = BuildR (\v u s -> (# v, u, s #)) + {-# INLINE mempty #-} + + mappend = (<>) + {-# INLINE mappend #-} + +instance Show BuildR + where + showsPrec prec builder = + showParen (prec > 10) + (showString "Proto3.Wire.Reverse.lazyByteString " . shows bytes) + where + bytes = snd (runBuildR builder) + +-- | Needed for rewrite rules; normally you would use '<>'. +appendBuildR :: BuildR -> BuildR -> BuildR +appendBuildR = \b c -> + let BuildR f = b + BuildR g = c + in + BuildR (\v0 u0 s0 -> case g v0 u0 s0 of (# v1, u1, s1 #) -> f v1 u1 s1) +{-# INLINE CONLIKE [1] appendBuildR #-} + +-- | Like 'foldl' but iterates right-to-left, which +-- is often useful when creating reverse builders. +foldlRVector :: Vector v a => (b -> a -> b) -> b -> v a -> b +foldlRVector f = \z v -> VG.foldr (flip f) z (VG.reverse v) + -- It may look like we create a reversed vector here, but thanks to + -- the rewrite rules in the vector library the vector is never actually + -- allocated, and instead we directly stream elements from right to left. +{-# INLINE foldlRVector #-} + +toBuildR :: (Ptr Word8 -> Int -> IO (Ptr Word8, Int)) -> BuildR +toBuildR f = + BuildR $ \v0 u0 s0 -> + let IO g = f (Ptr v0) (I# u0) in + case g s0 of (# s1, (Ptr v1, I# u1) #) -> (# v1, u1, s1 #) + +fromBuildR :: BuildR -> Ptr Word8 -> Int -> IO (Ptr Word8, Int) +fromBuildR (BuildR f) (Ptr v0) (I# u0) = + IO $ \s0 -> case f v0 u0 s0 of (# v1, u1, s1 #) -> (# s1, (Ptr v1, I# u1) #) + +-- | Eta-expands a function that produces a 'BuildR', so that +-- its input is not evaluated until the builder state is presented. +-- +-- This odd combinator seems to help performance at times, though +-- it may change behavior on nonterminating values of type @a@. +etaBuildR :: (a -> BuildR) -> a -> BuildR +etaBuildR f x = toBuildR $ \v u -> fromBuildR (f x) v u + +-- | The current state of execution of a builder +-- is a @'StablePtr' ('IORef' 'BuildRState')@. +-- +-- Current Buffer Layout: +-- +-- We devote the first few octets of the current buffer +-- to metadata that does not change very frequently: +-- +-- * 'Addr#': cast to 'StablePtr# (IORef BuildRState)'; indirect acceses +-- to the full builder state, which is used relatively infrequently. +-- +-- * 'Int#': the total number of non-metadata bytes originally available +-- within the current buffer before we started consuming them, +-- *plus* the number of bytes actually written to previous buffers. +-- We subtract the current unused figure to get the total bytes written. +-- +-- * `GHC.Float.Double#`: suitably-aligned scratch space for serialization +-- of 'Double' and 'Float' values. +-- +-- Though this choice imposes a small memory overhead in every buffer, +-- it reduces the time and space required to save and restore metadata +-- around the many non-inline calls that typically occur while writing +-- data into the buffer. +data BuildRState = BuildRState + { currentBuffer :: {-# UNPACK #-}!(P.MutableByteArray RealWorld) + -- ^ Specifies the current buffer. Note that through this field + -- every @'StablePtr' ('IORef' 'BuildRState')@ keeps one buffer + -- reachable until that stable pointer is explicitly destroyed. + , sealedBuffers :: BL.ByteString + -- ^ Holds the bytes written to previous buffers. We arrange for + -- this field to be in normal form (not just weak head normal form). + -- But to avoid redundant evaluation we do not mark it strict. + } + +-- | Allocates fields backward from offset 0 relative to some hypothetical +-- address, yielding the total size and alignment requirements, respectively, +-- along with the monadic return value. The total size includes any padding +-- at the end that is needed to make it a multiple of the overall alignment. +allocateFields :: State (Int, Int) a -> (a, Int, Int) +allocateFields fields = (x, size, align) + where + (x, (off, align)) = runState fields (0, 1) + size = mod off align - off + -- Aligns the overall size @- off@ by prepending @mod off align@ padding + -- bytes. Because @mod off align@ is in @[0, align)@ we are are neither + -- removing bytes nor adding more than we need. And for some @k@ we have + -- + -- > mod off align == off + k * align + -- + -- and therefore we achieve the precise alignment desired: + -- + -- > size = (off + k * align) - off == k * align + +-- | Within the monadic context established by 'allocateFields', +-- allocates one suitably-aligned field and returns its offset. +-- The argument is only a proxy for its type; we never evaluate it, +-- and therefore you may pass 'undefined'. +-- +-- WARNING: We assume that 'max' is the same as 'lcm' for any pair of +-- alignment values, so that we can avoid using 'lcm', which does not +-- evaluate at compile time. Compile-time evaluation helps our speed. +allocatePrimitiveField :: Storable a => a -> State (Int, Int) Int +allocatePrimitiveField proxy = state $ \(prevOff, prevAlign) -> + let fieldWidth = sizeOf proxy + fieldAlign = alignment proxy + unaligned = prevOff - fieldWidth + nextOff = unaligned - mod unaligned fieldAlign + nextAlign = max prevAlign fieldAlign + in (nextOff, (nextOff, nextAlign)) + +scratchOffset, spaceOffset, stateOffset, metaDataSize, metaDataAlign :: Int +((scratchOffset, spaceOffset, stateOffset), metaDataSize, metaDataAlign) = + allocateFields $ + (,,) <$> allocatePrimitiveField (undefined :: Double) + <*> allocatePrimitiveField (undefined :: Int) + <*> allocatePrimitiveField (undefined :: Ptr ()) + -- Note that we are allocating backward, so this + -- will put the pointer at the lowest address. + +smallChunkSize, defaultChunkSize :: Int +smallChunkSize = BB.smallChunkSize - metaDataSize +defaultChunkSize = BB.defaultChunkSize - metaDataSize + +data MetaData + +metaPtr :: Ptr Word8 -> Int -> Ptr MetaData +metaPtr v = plusPtr v . negate + +readState :: Ptr MetaData -> IO (StablePtr (IORef BuildRState)) +readState m = castPtrToStablePtr <$> peekByteOff m stateOffset + +writeState :: Ptr MetaData -> StablePtr (IORef BuildRState) -> IO () +writeState m = pokeByteOff m stateOffset . castStablePtrToPtr + +readSpace :: Ptr MetaData -> IO Int +readSpace m = peekByteOff m spaceOffset + +writeSpace :: Ptr MetaData -> Int -> IO () +writeSpace m = pokeByteOff m spaceOffset + +-- | The arguments are the same as the 'BuildR' arguments. +readTotal :: Ptr Word8 -> Int -> IO Int +readTotal v unused = do + -- Because we do not wish to update a record of the total + -- every time we write a byte, instead we record "space", + -- which changes rarely, and subtract "unused" from it + -- when we need to compute the total, which is somewhat + -- frequent but not as frequent as updates to "unused". + space <- readSpace (metaPtr v unused) + let !total = space - unused + + -- GHC (at least v8.2.2 and v8.6.5) seems quite eager to delay the above + -- subtraction, even though we have indicated that the computation of + -- "total" is strict, and even though delaying the subtraction across + -- a non-inline call requires saving and restoring two registers + -- ("space" and "unused") instead of one ("total"). Unless we were to + -- completely ignore the result of the subtraction, which would be quite + -- unusual, an eager subtraction is faster. Therefore we force it: + strictify total + +-- | Sometimes GHC (at least v8.2.2 and v8.6.5) appears to be lazy even with +-- unlifted values, and we apply this combination to force computation so that +-- we do not have to save and restore the several inputs to the computation. +-- +-- The implementation requires converting the 'Int#' to a lifted pointer +-- type and then invoking 'touch#' on it, which is slightly questionable +-- because we would crash if the garbage collector actually followed the +-- converted value. But there would be no reason to collect between the +-- conversion and the 'touch#' because that span involves no computation. +strictify :: Int -> IO Int +strictify (I# x) = IO $ \s0 -> + case addrToAny# (int2Addr# x) of + (# y #) -> case touch# y s0 of + s1 -> (# s1, I# x #) + +-- | Allocates a new buffer and stores a pointer to that buffer in +-- the 'currentBuffer' field of the overall builder state, along with the +-- first argument, then returns a pointer to the end of the payload area. +-- +-- (This is a manual wrapper around 'newBuffer#'.) +newBuffer :: + -- | All bytes previously written. + -- + -- It is ASSUMED that the caller already fully + -- evaluated this otherwise-lazy 'BL.ByteString'. + BL.ByteString -> + -- | Total number of bytes previously written. + Int -> + -- | Builder state variable. The old value of this variable + -- will NOT be used; rather, it will be overwritten. + -- Therefore that old value may be 'undefined'. + IORef BuildRState -> + -- | Stable pointer to builder state variable. + StablePtr (IORef BuildRState) -> + -- | Desired payload size of new current buffer, not counting metadata. + Int -> + IO (Ptr Word8) +newBuffer sealed (I# total) (IORef (STRef stateVar)) (StablePtr stateSP) + (I# unused) = + IO $ \s0 -> + case newBuffer# sealed total stateVar stateSP unused s0 of + (# s1, addr #) -> (# s1, Ptr addr #) + +newBuffer# :: + BL.ByteString -> + Int# -> + MutVar# RealWorld BuildRState -> + StablePtr# (IORef BuildRState) -> + Int# -> + State# RealWorld -> + (# State# RealWorld, Addr# #) +newBuffer# sealed total stateVar stateSP unused s0 = + case go s0 of + (# s1, Ptr addr #) -> (# s1, addr #) + where + IO go = do + let allocation = metaDataSize + I# unused + buf <- P.newAlignedPinnedByteArray allocation metaDataAlign + let !(PTR base) = P.mutableByteArrayContents buf + !v = plusPtr (Ptr base) (metaDataSize + I# unused) + !m = plusPtr (Ptr base) metaDataSize + writeState m (StablePtr stateSP) + writeSpace m (I# unused + I# total) + let !nextState = BuildRState{currentBuffer = buf, sealedBuffers = sealed} + writeIORef (IORef (STRef stateVar)) nextState + pure v + +-- | The result of a call to 'sealBuffer'. +data SealedState = SealedState + { sealedSB :: BL.ByteString + -- ^ All bytes written thus far. + , totalSB :: {-# UNPACK #-}!Int + -- ^ The total number of bytes written thus far. + , stateVarSB :: {-# UNPACK #-}!(IORef BuildRState) + -- ^ The builder state variable. + -- This function does NOT modify that variable--it will still + -- refer to the old buffer unless and until you modify it. + , statePtrSB :: {-# UNPACK #-}!(StablePtr (IORef BuildRState)) + -- ^ The stable pointer to the variable referenced by 'stateVarSB'. + , recycledSB :: Maybe (P.MutableByteArray RealWorld) + -- ^ Returns ownership of the old current buffer to the caller + -- if it is no longer needed to track the already-written bytes. + -- + -- If you reuse it within the same builder then there is + -- no need to reset the stable pointer to the state variable, + -- but please be sure to update the "space" metadatum. + } + +-- | Takes ownership of the current buffer, +-- but sometimes hands it back for reuse. +-- +-- If more building is required then please allocate a new current buffer +-- and update the builder state variable accordingly. +-- +-- (This is a manual wrapper around 'sealBuffer#'.) +sealBuffer :: + -- | Pointer to the used portion of the current buffer. + Ptr Word8 -> + -- | The number of bytes still unused in the current buffer. + Int -> + IO SealedState +sealBuffer (Ptr addr) (I# u) = IO $ \s0 -> + case sealBuffer# addr u s0 of + (# s1, sealed, total, stateVar, statePtr, recycled #) -> + (# s1 + , SealedState + { sealedSB = sealed + , totalSB = I# total + , stateVarSB = IORef (STRef stateVar) + , statePtrSB = StablePtr statePtr + , recycledSB = recycled + } + #) + +sealBuffer# :: + Addr# -> + Int# -> + State# RealWorld -> + (# State# RealWorld + , BL.ByteString + , Int# + , MutVar# RealWorld BuildRState + , StablePtr# (IORef BuildRState) + , Maybe (P.MutableByteArray RealWorld) + #) +sealBuffer# addr unused s0 = + case go s0 of + (# s1, (sealed, I# total, IORef (STRef sv), StablePtr sp, re) #) -> + (# s1, sealed, total, sv, sp, re #) + where + IO go = do + let v = Ptr addr + statePtr <- readState (metaPtr v (I# unused)) + stateVar <- deRefStablePtr statePtr + BuildRState { currentBuffer = buffer, sealedBuffers = oldSealed } <- + readIORef stateVar + total <- readTotal v (I# unused) + -- The above call to 'readTotal' is the last access of the current + -- buffer through a raw pointer made by this function. Therefore + -- we must be sure that the current buffer remains reachable at this + -- point in the state thread. And we are sure of that fact, because + -- until a state action frees the stable pointer or modifies the state + -- variable, the stable pointer will reference the state variable, + -- which in turn will reference the current buffer. + let allocation = P.sizeofMutableByteArray buffer - metaDataSize + if allocation <= I# unused + then + pure (oldSealed, total, stateVar, statePtr, Just buffer) + else do + let !(PTR base) = P.mutableByteArrayContents buffer + !(P.MutableByteArray mba) = buffer + fp = ForeignPtr base (PlainPtr mba) + offset = metaDataSize + I# unused + finish trimmed recycled = do + let !newSealed = BLI.Chunk trimmed oldSealed + pure (newSealed, total, stateVar, statePtr, recycled) + untrimmed = BI.fromForeignPtr fp offset (allocation - I# unused) + if offset <= B.length untrimmed + then finish untrimmed Nothing + else finish (B.copy untrimmed) (Just buffer) + +-- | Like `Proto3.Wire.Reverse.toLazyByteString` but also +-- returns the total length of the lazy 'BL.ByteString', +-- which is computed as a side effect of encoding. +runBuildR :: BuildR -> (Int, BL.ByteString) +runBuildR f = unsafePerformIO $ do + stateVar <- newIORef undefined -- undefined only until 'newBuffer' + bracket (newStablePtr stateVar) freeStablePtr $ \statePtr -> do + let u0 = smallChunkSize + v0 <- newBuffer BL.empty 0 stateVar statePtr u0 + (v1, u1) <- fromBuildR f v0 u0 + SealedState { sealedSB = bytes, totalSB = total } <- sealBuffer v1 u1 + pure (total, bytes) + +-- | First reads the number of unused bytes in the current buffer. +withUnused :: (Int -> BuildR) -> BuildR +withUnused f = toBuildR $ \v u -> fromBuildR (f u) v u + +-- | First reads the number of bytes previously written. +withTotal :: (Int -> BuildR) -> BuildR +withTotal f = withTotal# (\total -> f (I# total)) + +-- | First reads the number of bytes previously written. +withTotal# :: (Int# -> BuildR) -> BuildR +withTotal# f = toBuildR $ \v u -> do + I# total <- readTotal v u + fromBuildR (f total) v u + +-- | Executes the right builder, measuring how many bytes +-- it writes, then provides that figure to the left builder. +withLengthOf :: (Int -> BuildR) -> BuildR -> BuildR +withLengthOf = \f g -> withLengthOf# (\len -> f (I# len)) g +{-# INLINE CONLIKE withLengthOf #-} + +-- | Executes the right builder, measuring how many bytes +-- it writes, then provides that figure to the left builder. +withLengthOf# :: (Int# -> BuildR) -> BuildR -> BuildR +withLengthOf# = \f g -> toBuildR $ \v0 u0 -> do + !before <- readTotal v0 u0 + (v1, u1) <- fromBuildR g v0 u0 + !after <- readTotal v1 u1 + let !(I# len) = after - before + fromBuildR (f len) v1 u1 +{-# INLINE CONLIKE [1] withLengthOf# #-} -- See Prim module for rules. + +-- | Seals the current buffer and creates a new +-- one with at least the given number of bytes. +reallocate :: Int -> BuildR +reallocate (I# required) = reallocate# required + +reallocate# :: Int# -> BuildR +reallocate# required = toBuildR $ \v0 u0 -> do + SealedState + { sealedSB = bytes + , totalSB = total + , stateVarSB = IORef (STRef stateVar) + , statePtrSB = StablePtr statePtr + } <- sealBuffer v0 u0 + let !u1 = max (I# required) defaultChunkSize + v1 <- newBuffer bytes total (IORef (STRef stateVar)) (StablePtr statePtr) u1 + pure (v1, u1) +{-# NOINLINE reallocate# #-} -- Avoid code bloat in library clients. + +-- | Called by 'prependChunk' and 'prependReverseChunks' +-- to prepare a current buffer. +-- +-- (This is a manual wrapper around 'afterPrependChunks#'.) +afterPrependChunks :: SealedState -> IO (Ptr Word8, Int) +afterPrependChunks !st = IO $ \s0 -> + case afterPrependChunks# st s0 of + (# v1, u1, s1 #) -> (# s1, (Ptr v1, I# u1) #) + +afterPrependChunks# :: + SealedState -> + State# RealWorld -> + (# Addr#, Int#, State# RealWorld #) +afterPrependChunks# SealedState + { sealedSB = sealed + , totalSB = total + , stateVarSB = stateVar + , statePtrSB = statePtr + , recycledSB = recycled + } s0 = + case go s0 of (# s2, (Ptr v2, I# u2) #) -> (# v2, u2, s2 #) + where + IO go = case recycled of + Nothing -> do + -- The old buffer is part of 'sealed'. Allocate a new buffer. + let u1 = defaultChunkSize + v1 <- newBuffer sealed total stateVar statePtr u1 + pure (v1, u1) + + Just buf -> do + -- Recycle the old current buffer, from which + -- we already copied what we wished to keep. + let u1 = P.sizeofMutableByteArray buf - metaDataSize + !(PTR base) = P.mutableByteArrayContents buf + !v1 = plusPtr (Ptr base) (metaDataSize + u1) + !m = plusPtr (Ptr base) metaDataSize + writeSpace m (u1 + total) + let !nextState = BuildRState + { currentBuffer = buf, sealedBuffers = sealed } + writeIORef stateVar nextState + pure (v1, u1) + +-- | Prepends a 'B.ByteString' to the output. +-- +-- NOTE: This is a relatively heavyweight operation. For small +-- strings it may be faster to copy them to the current buffer. +prependChunk :: B.ByteString -> BuildR +prependChunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) + | I# len == 0 = mempty + | otherwise = BuildR (\v u s -> prependChunk# v u s ad ct off len) + +prependChunk# :: + -- | Used bytes. + Addr# -> + -- | Count of unused bytes. + Int# -> + -- | State token. + State# RealWorld -> + -- | Base address of 'B.ByteString'. + Addr# -> + -- | Finalizer for 'B.ByteString'. + ForeignPtrContents -> + -- | Offset from base of 'B.ByteString'. + Int# -> + -- | Length of 'B.ByteString'. + Int# -> + (# Addr#, Int#, State# RealWorld #) +prependChunk# v u s ad ct off len = go v u s + where + BuildR go = toBuildR $ \v1 u1 -> do + SealedState + { sealedSB = oldSealed + , totalSB = oldTotal + , stateVarSB = stateVar + , statePtrSB = statePtr + , recycledSB = recycled + } <- sealBuffer v1 u1 + + let chunk = BI.PS (ForeignPtr ad ct) (I# off) (I# len) + + afterPrependChunks SealedState + { sealedSB = BLI.Chunk chunk oldSealed + , totalSB = I# len + oldTotal + , stateVarSB = stateVar + , statePtrSB = statePtr + , recycledSB = recycled + } + +-- | Like 'BL.ByteString', but with the chunks in reverse order, +-- even though the bytes within each chunk are in forward order. +newtype ReverseChunks = ReverseChunks { getReverseChunks :: BL.ByteString } + +-- | Equivalent to the following, but faster: +-- +-- > foldMap prependChunk . reverse . getReverseChunks +-- +-- NOTE: This is a relatively heavyweight operation. For small +-- strings it may be faster to copy them to the current buffer. +prependReverseChunks :: ReverseChunks -> BuildR +prependReverseChunks (ReverseChunks BLI.Empty) = mempty +prependReverseChunks + (ReverseChunks (BLI.Chunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) cs)) = + BuildR (\v u s -> prependReverseChunks# v u s ad ct off len cs) + +prependReverseChunks# :: + -- | Used bytes. + Addr# -> + -- | Count of unused bytes. + Int# -> + -- | State token. + State# RealWorld -> + -- | Base address of first 'B.ByteString' chunk. + Addr# -> + -- | Finalizer for first 'B.ByteString' chunk. + ForeignPtrContents -> + -- | Offset from base of first 'B.ByteString' chunk. + Int# -> + -- | Length of first 'B.ByteString' chunk. + Int# -> + -- | Other chunks. + BL.ByteString -> + (# Addr#, Int#, State# RealWorld #) +prependReverseChunks# v0 u0 s0 ad ct off len cs0 = go v0 u0 s0 + where + BuildR go = toBuildR $ \v1 u1 -> do + SealedState + { sealedSB = oldSealed + , totalSB = oldTotal + , stateVarSB = stateVar + , statePtrSB = statePtr + , recycledSB = recycled + } <- sealBuffer v1 u1 + + let appendChunks !total sealed (BLI.Chunk c cs) = + appendChunks (B.length c + total) (BLI.Chunk c sealed) cs + appendChunks newTotal newSealed BLI.Empty = + afterPrependChunks SealedState + { sealedSB = newSealed + , totalSB = newTotal + , stateVarSB = stateVar + , statePtrSB = statePtr + , recycledSB = recycled + } + + let rchunks = BLI.Chunk (BI.PS (ForeignPtr ad ct) (I# off) (I# len)) cs0 + + appendChunks oldTotal oldSealed rchunks + +-- | Ensures that the current buffer has at least the given +-- number of bytes before executing the given builder. +ensure :: Int -> BuildR -> BuildR +ensure (I# required) f = ensure# required f + +ensure# :: Int# -> BuildR -> BuildR +ensure# required (BuildR f) = BuildR $ \v u s -> + if I# required <= I# u + then f v u s + else let BuildR g = BuildR f <> reallocate# required in g v u s + +-- | ASSUMES that the specified number of bytes is both nonnegative and +-- less than or equal to the number of unused bytes in the current buffer, +-- consumes that number of unused bytes, and provides their starting address. +unsafeConsume :: Int -> (Ptr Word8 -> IO ()) -> BuildR +unsafeConsume = \width f -> + toBuildR $ \v0 u0 -> do + let !m = - width + !v1 = plusPtr v0 m + !u1 = u0 + m + f v1 + pure (v1, u1) +{-# INLINE unsafeConsume #-} + +-- | Given the builder inputs and a 'Float', converts +-- that number to its bit pattern in native byte order. +floatToWord32 :: Ptr Word8 -> Int -> Float -> IO Word32 +floatToWord32 v u x = do + let m = metaPtr v u + pokeByteOff m scratchOffset x + peekByteOff m scratchOffset + +-- | Given the builder inputs and a 'Double', converts +-- that number to its bit pattern in native byte order. +doubleToWord64 :: Ptr Word8 -> Int -> Double -> IO Word64 +doubleToWord64 v u x = do + let m = metaPtr v u + pokeByteOff m scratchOffset x + peekByteOff m scratchOffset diff --git a/src/Proto3/Wire/Reverse/Prim.hs b/src/Proto3/Wire/Reverse/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Reverse/Prim.hs @@ -0,0 +1,838 @@ +{- + Copyright 2020 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | Implementation details of the "Data.ByteString.Reverse" module. +-- Breaking changes will be more frequent in this module; use with caution. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module Proto3.Wire.Reverse.Prim + ( -- * Combine types such as `BoundedPrim` and `FixedPrim`. + AssocPlusNat(..) + , CommPlusNat(..) + , PChoose(..) + , Max + , AssocMaxNat(..) + , CommMaxNat(..) + + -- * Architectural attributes. + , StoreMethod(..) + , storeMethod + , ByteOrder(..) + , systemByteOrder + + -- * Bounded primitives. + , BoundedPrim(..) + , liftBoundedPrim + , composeBoundedPrim + , unsafeBuildBoundedPrim + + -- * Fixed-width primitives. + , FixedPrim + , liftFixedPrim + , word8 + , word16 + , word16Native + , word16BE + , word16LE + , word32 + , word32Native + , word32BE + , word32LE + , word64 + , word64Native + , word64BE + , word64LE + , int8 + , int16 + , int16Native + , int16BE + , int16LE + , int32 + , int32Native + , int32BE + , int32LE + , int64 + , int64Native + , int64BE + , int64LE + , float + , floatNative + , floatBE + , floatLE + , double + , doubleNative + , doubleBE + , doubleLE + , charUtf8 + , wordBase128LEVar + , wordBase128LEVar_inline + , word32Base128LEVar + , word32Base128LEVar_inline + , word64Base128LEVar + , word64Base128LEVar_inline + , vectorFixedPrim + ) where + +import Data.Bits ( Bits(..) ) +import Data.Bool ( bool ) +import Data.Char ( ord ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Kind ( Type ) +import qualified Data.Vector.Generic +import Data.Word ( Word16, + byteSwap16, byteSwap32, + byteSwap64 ) +import Foreign ( Storable(..) ) +import GHC.Exts ( Addr#, Int#, Proxy#, + RealWorld, State#, (+#), + and#, inline, or#, + plusAddr#, plusWord#, proxy#, + uncheckedShiftRL# ) +import GHC.IO ( IO(..) ) +import GHC.Int ( Int(..) ) +import GHC.Ptr ( Ptr(..) ) +import GHC.TypeLits ( KnownNat, Nat, + type (+), natVal' ) +import GHC.Word ( Word(..), Word8(..), + Word32(..), Word64(..) ) +import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..), + (&<>) ) +import Parameterized.Data.Monoid ( PMEmpty(..) ) +import Proto3.Wire.Reverse.Internal +import Proto3.Wire.Reverse.Width ( AssocPlusNat(..), + CommPlusNat(..), + PChoose(..), + Max, AssocMaxNat(..), + CommMaxNat(..) ) + +#include /* for WORDS_BIGENDIAN and WORD_SIZE_IN_BITS */ + +-- "ghc-prim" v0.6.1 defines `GHC.Prim.Ext.WORD64`, but we do not wish +-- to require that version of "ghc-prim". Therefore we define it locally. +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 (Word64#) +type WORD64 = Word64# +#else +import GHC.Exts (Word#) +type WORD64 = Word# +#endif + +-- $setup +-- >>> :set -XOverloadedStrings + +-- | Are we restricted to aligned writes only? +data StoreMethod = StoreAligned | StoreUnaligned + deriving (Eq, Show) + +-- | 'StoreUnaligned' if the Cabal file defines @UNALIGNED_POKES@, which it +-- does on architectures where that approach is known to be safe and faster +-- then writing bytes one by one. Otherwise 'StoreAligned'. +storeMethod :: StoreMethod +#if defined(UNALIGNED_POKES) +storeMethod = StoreUnaligned +#else +storeMethod = StoreAligned +#endif + +-- | Specifies order in which the bytes of an integer are encoded. +data ByteOrder + = BigEndian -- ^ Most significant byte first. + | LittleEndian -- ^ Least significant byte first. + deriving (Eq, Show) + +-- | The 'ByteOrder' native to the current architecture. +-- +-- For example, the order of the bytes when you poke a 'Word32'. +systemByteOrder :: ByteOrder +-- WORDS_BIGENDIAN is defined for big-endian architectures +-- by the GHC header . +#if defined(WORDS_BIGENDIAN) +systemByteOrder = BigEndian +#else +systemByteOrder = LittleEndian +#endif + +-- | A 'BuildR' together with a type-level bound on the number of bytes +-- written and a requirement that the current buffer already contain at +-- least that many bytes. +-- +-- As in the "bytestring" package, the purpose of a bounded primitive is to +-- improve speed by consolidating the space checks of several small builders. +newtype BoundedPrim (w :: Nat) = BoundedPrim BuildR + +type role BoundedPrim nominal + +type instance PNullary BoundedPrim width = BoundedPrim width + +instance (w1 + w2) ~ w3 => + PSemigroup BoundedPrim w1 w2 w3 + where + pmappend = composeBoundedPrim + {-# INLINE CONLIKE pmappend #-} + +instance AssocPlusNat BoundedPrim u v w + where + assocLPlusNat = assocLPlusNatBoundedPrim + {-# INLINE CONLIKE assocLPlusNat #-} + + assocRPlusNat = assocRPlusNatBoundedPrim + {-# INLINE CONLIKE assocRPlusNat #-} + +instance CommPlusNat BoundedPrim u v + where + commPlusNat _ (BoundedPrim f) = BoundedPrim f + {-# INLINE CONLIKE commPlusNat #-} + +instance PMEmpty BoundedPrim 0 + where + pmempty = BoundedPrim mempty + {-# INLINE CONLIKE pmempty #-} + +instance Max u v ~ w => + PChoose BoundedPrim u v w + where + pbool = \(BoundedPrim f) (BoundedPrim g) -> BoundedPrim . bool f g + {-# INLINE CONLIKE pbool #-} + +instance AssocMaxNat BoundedPrim u v w + where + assocLMaxNat = \_ (BoundedPrim f) -> BoundedPrim f + {-# INLINE CONLIKE assocLMaxNat #-} + + assocRMaxNat = \_ (BoundedPrim f) -> BoundedPrim f + {-# INLINE CONLIKE assocRMaxNat #-} + +instance CommMaxNat BoundedPrim u v + where + commMaxNat = \_ (BoundedPrim f) -> BoundedPrim f + {-# INLINE CONLIKE commMaxNat #-} + +-- | Like 'assocLPlusNat' but can be used in rules without +-- causing GHC to think the class dictionary is recursive. +assocLPlusNatBoundedPrim :: + forall u v w . + Proxy# '(u, v, w) -> BoundedPrim (u + (v + w)) -> BoundedPrim ((u + v) + w) +assocLPlusNatBoundedPrim = \_ (BoundedPrim f) -> BoundedPrim f +{-# INLINE CONLIKE assocLPlusNatBoundedPrim #-} + +-- | Like 'assocRPlusNat' but can be used in rules without +-- causing GHC to think the class dictionary is recursive. +assocRPlusNatBoundedPrim :: + forall u v w . + Proxy# '(u, v, w) -> BoundedPrim ((u + v) + w) -> BoundedPrim (u + (v + w)) +assocRPlusNatBoundedPrim = \_ (BoundedPrim f) -> BoundedPrim f +{-# INLINE CONLIKE assocRPlusNatBoundedPrim #-} + +-- | Needed for rewrite rules; normally you would use 'pmappend' or '(&<>)'. +composeBoundedPrim :: BoundedPrim v -> BoundedPrim w -> BoundedPrim (v + w) +composeBoundedPrim = + \(BoundedPrim f) (BoundedPrim g) -> BoundedPrim (f <> g) +{-# INLINE CONLIKE [1] composeBoundedPrim #-} + +-- | Executes the bounded primitive WITHOUT first ensuring it has enough space. +unsafeBuildBoundedPrim :: BoundedPrim w -> BuildR +unsafeBuildBoundedPrim (BoundedPrim build) = build + +-- | Executes the given bounded primitive +-- after obtaining the space it requires. +liftBoundedPrim :: forall w . KnownNat w => BoundedPrim w -> BuildR +liftBoundedPrim = case fromInteger (natVal' (proxy# :: Proxy# w)) of + I# w -> unsafeLiftBoundedPrim w +{-# INLINE CONLIKE liftBoundedPrim #-} + +-- | Needed for rewrite rules; normally you would use 'liftBoundedPrim'. +unsafeLiftBoundedPrim :: Int# -> BoundedPrim w -> BuildR +unsafeLiftBoundedPrim = \w (BoundedPrim f) -> ensure# w f +{-# INLINE CONLIKE [1] unsafeLiftBoundedPrim #-} + +{-# RULES + +"appendBuildR/unsafeLiftBoundedPrim" forall w1 w2 f1 f2 . + appendBuildR (unsafeLiftBoundedPrim w1 f1) (unsafeLiftBoundedPrim w2 f2) + = unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2) + +"appendBuildR/unsafeLiftBoundedPrim/assoc_r" forall w1 w2 f1 f2 b . + appendBuildR (unsafeLiftBoundedPrim w1 f1) + (appendBuildR (unsafeLiftBoundedPrim w2 f2) b) + = appendBuildR (unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2)) b + +"appendBuildR/unsafeLiftBoundedPrim/assoc_l" forall w1 w2 f1 f2 b . + appendBuildR (appendBuildR b (unsafeLiftBoundedPrim w1 f1)) + (unsafeLiftBoundedPrim w2 f2) + = appendBuildR b (unsafeLiftBoundedPrim (w1 +# w2) (composeBoundedPrim f1 f2)) + + #-} + +-- | Similar to a 'BoundedPrim' but also consolidates address updates in +-- order to take advantage of machine instructions that write at an offset. +-- +-- The additional input is an offset from the current address +-- that specifies the beginning of the region being encoded. +-- +-- (If GHC learns to consolidate address offsets automatically +-- then we might be able to just use 'BoundedPrim' instead.) +newtype FixedPrim (w :: Nat) = FixedPrim + ( Addr# -> Int# -> State# RealWorld -> Int# -> + (# Addr#, Int#, State# RealWorld #) + ) + +type role FixedPrim nominal + +type instance PNullary FixedPrim width = FixedPrim width + +instance ((w1 + w2) ~ w3, KnownNat w1) => + PSemigroup FixedPrim w1 w2 w3 + where + pmappend = \(FixedPrim f) (FixedPrim g) -> + case fromInteger (natVal' (proxy# :: Proxy# w1)) of + I# w1 -> FixedPrim + ( \v0 u0 s0 o -> case g v0 u0 s0 (o +# w1) of + (# v1, u1, s1 #) -> f v1 u1 s1 o ) + {-# INLINE CONLIKE pmappend #-} + +instance AssocPlusNat FixedPrim u v w + where + assocLPlusNat = \_ (FixedPrim f) -> FixedPrim f + {-# INLINE CONLIKE assocLPlusNat #-} + + assocRPlusNat = \_ (FixedPrim f) -> FixedPrim f + {-# INLINE CONLIKE assocRPlusNat #-} + +instance CommPlusNat FixedPrim u v + where + commPlusNat = \_ (FixedPrim f) -> FixedPrim f + {-# INLINE CONLIKE commPlusNat #-} + +instance PMEmpty FixedPrim 0 + where + pmempty = FixedPrim (\v u s _ -> (# v, u, s #)) + {-# INLINE CONLIKE pmempty #-} + +-- | Executes the given fixed primitive and adjusts the current address. +liftFixedPrim :: forall w . KnownNat w => FixedPrim w -> BoundedPrim w +liftFixedPrim = \(FixedPrim f) -> BoundedPrim (BuildR (g f)) + where + !(I# o) = - fromInteger (natVal' (proxy# :: Proxy# w)) + g = \f v0 u0 s0 -> case f v0 u0 s0 o of + (# v1, u1, s1 #) -> (# plusAddr# v1 o, u1 +# o, s1 #) + {-# INLINE g #-} +{-# INLINE CONLIKE [1] liftFixedPrim #-} + +{-# RULES + +"composeBoundedPrim/liftFixedPrim" + forall (f1 :: KnownNat w1 => FixedPrim w1) + (f2 :: KnownNat (w1 + w2) => FixedPrim w2). + composeBoundedPrim (liftFixedPrim f1) (liftFixedPrim f2) + = liftFixedPrim (pmappend f1 f2) + +"composeBoundedPrim/liftFixedPrim/assoc_r" + forall (f1 :: KnownNat w1 => FixedPrim w1) + (f2 :: KnownNat (w1 + w2) => FixedPrim w2) + (b3 :: BoundedPrim w3) . + composeBoundedPrim (liftFixedPrim f1) + (composeBoundedPrim (liftFixedPrim f2) b3) + = assocRPlusNatBoundedPrim (proxy# :: Proxy# '(w1, w2, w3)) + (composeBoundedPrim (liftFixedPrim (pmappend f1 f2)) b3) + +"composeBoundedPrim/liftFixedPrim/assoc_l" + forall (b1 :: BoundedPrim w1) + (f2 :: KnownNat w2 => FixedPrim w2) + (f3 :: KnownNat (w2 + w3) => FixedPrim w3) . + composeBoundedPrim (composeBoundedPrim b1 (liftFixedPrim f2)) + (liftFixedPrim f3) + = assocLPlusNatBoundedPrim (proxy# :: Proxy# '(w1, w2, w3)) + (composeBoundedPrim b1 (liftFixedPrim (pmappend f2 f3))) + +"withLengthOf#/unsafeLiftBoundedPrim/liftFixedPrim" forall f w g . + withLengthOf# f (unsafeLiftBoundedPrim w (liftFixedPrim g)) + = appendBuildR (f w) (unsafeLiftBoundedPrim w (liftFixedPrim g)) + + #-} + +-- | Required: +-- +-- > fromInteger (natVal' (proxy# :: Proxy# (StorableWidth a))) = +-- > sizeOf (undefined :: x) +type family StorableWidth (a :: Type) :: Nat + +type instance StorableWidth Word8 = 1 +type instance StorableWidth Word16 = 2 +type instance StorableWidth Word32 = 4 +type instance StorableWidth Word64 = 8 + +type instance StorableWidth Int8 = 1 +type instance StorableWidth Int16 = 2 +type instance StorableWidth Int32 = 4 +type instance StorableWidth Int64 = 8 + +type instance StorableWidth Float = 4 +type instance StorableWidth Double = 8 + +-- | WARNING: The write may be unaligned; check 'storeMethod' first. +primPoke :: Storable x => x -> FixedPrim (StorableWidth x) +primPoke !x = FixedPrim p + where + p v u s0 o = + let IO q = pokeByteOff (Ptr v) (I# o) x + in case q s0 of (# s1, (_ :: ()) #) -> (# v, u, s1 #) + +-- | Fixed-width primitive that writes a single byte as-is. +word8 :: Word8 -> FixedPrim 1 +word8 = primPoke + -- Byte order and alignment do not matter for a single byte. + +-- | Shifts right by @s@ bits, then writes the least significant byte. +word8Shift :: Int -> Word -> FixedPrim 1 +word8Shift s x = word8 (fromIntegral (shiftR x s)) + +-- | Shifts right by @s@ bits, then writes the least significant 16-bit word. +word16Shift :: ByteOrder -> Int -> Word -> FixedPrim 2 +word16Shift bo = case bo of + BigEndian -> \(!s) (!x) -> p (s + h) x &<> p s x + LittleEndian -> \(!s) (!x) -> p s x &<> p (s + h) x + where + h = 8 + p = word8Shift + +-- | Writes the least significant 32-bit word, one byte at a time. +word32Shift :: ByteOrder -> Word -> FixedPrim 4 +word32Shift bo = case bo of + BigEndian -> \(!x) -> p h x &<> p 0 x + LittleEndian -> \(!x) -> p 0 x &<> p h x + where + h = 16 + p = word16Shift bo + +-- | Writes one byte at a time. +word64Shift :: ByteOrder -> Word64 -> FixedPrim 8 +word64Shift bo = case bo of + BigEndian -> \(!x) -> p (h x) &<> p x + LittleEndian -> \(!x) -> p x &<> p (h x) + where + h x = shiftR x 32 + p = word32Shift bo . fromIntegral @Word64 @Word + +-- | Fixed-width primitive that writes a 16-bit word +-- in the specified byte order. +word16 :: ByteOrder -> Word16 -> FixedPrim 2 +word16 !bo !x = case storeMethod of + StoreAligned -> word16Shift bo 0 (fromIntegral x) + StoreUnaligned + | systemByteOrder == bo -> primPoke x + | otherwise -> primPoke (byteSwap16 x) + +-- | Fixed-width primitive that writes a 16-bit word +-- in native byte order. +word16Native :: Word16 -> FixedPrim 2 +word16Native = word16 systemByteOrder + +-- | Fixed-width primitive that writes a 16-bit word +-- in big-endian byte order. +word16BE :: Word16 -> FixedPrim 2 +word16BE = word16 BigEndian + +-- | Fixed-width primitive that writes a 16-bit word +-- in little-endian byte order. +word16LE :: Word16 -> FixedPrim 2 +word16LE = word16 LittleEndian + +-- | Fixed-width primitive that writes a 32-bit word +-- in the specified byte order. +word32 :: ByteOrder -> Word32 -> FixedPrim 4 +word32 !bo !x = case storeMethod of + StoreAligned -> word32Shift bo (fromIntegral x) + StoreUnaligned + | systemByteOrder == bo -> primPoke x + | otherwise -> primPoke (byteSwap32 x) + +-- | Fixed-width primitive that writes a 32-bit word +-- in native byte order. +word32Native :: Word32 -> FixedPrim 4 +word32Native = word32 systemByteOrder + +-- | Fixed-width primitive that writes a 32-bit word +-- in big-endian byte order. +word32BE :: Word32 -> FixedPrim 4 +word32BE = word32 BigEndian + +-- | Fixed-width primitive that writes a 32-bit word +-- in little-endian byte order. +word32LE :: Word32 -> FixedPrim 4 +word32LE = word32 LittleEndian + +-- | Fixed-width primitive that writes a 64-bit word +-- in the specified byte order. +word64 :: ByteOrder -> Word64 -> FixedPrim 8 +word64 !bo !x = case storeMethod of + StoreAligned -> word64Shift bo (fromIntegral x) + StoreUnaligned + | systemByteOrder == bo -> primPoke x + | otherwise -> primPoke (byteSwap64 x) + +-- | Fixed-width primitive that writes a 64-bit word +-- in native byte order. +word64Native :: Word64 -> FixedPrim 8 +word64Native = word64 systemByteOrder + +-- | Fixed-width primitive that writes a 64-bit word +-- in big-endian byte order. +word64BE :: Word64 -> FixedPrim 8 +word64BE = word64 BigEndian + +-- | Fixed-width primitive that writes a 64-bit word +-- in little-endian byte order. +word64LE :: Word64 -> FixedPrim 8 +word64LE = word64 LittleEndian + +-- | @'word8' . 'fromIntegral'@ +int8 :: Int8 -> FixedPrim 1 +int8 = word8 . fromIntegral + +-- | @\bo -> 'word16' bo . 'fromIntegral'@ +int16 :: ByteOrder -> Int16 -> FixedPrim 2 +int16 !bo = word16 bo . fromIntegral + +-- | @'word16Native' . 'fromIntegral'@ +int16Native :: Int16 -> FixedPrim 2 +int16Native = word16Native . fromIntegral + +-- | @'word16BE' . 'fromIntegral'@ +int16BE :: Int16 -> FixedPrim 2 +int16BE = word16BE . fromIntegral + +-- | @'word16LE' . 'fromIntegral'@ +int16LE :: Int16 -> FixedPrim 2 +int16LE = word16LE . fromIntegral + +-- | @\bo -> 'word32' bo . 'fromIntegral'@ +int32 :: ByteOrder -> Int32 -> FixedPrim 4 +int32 bo = word32 bo . fromIntegral + +-- | @'word32Native' . 'fromIntegral'@ +int32Native :: Int32 -> FixedPrim 4 +int32Native = word32Native . fromIntegral + +-- | @'word32BE' . 'fromIntegral'@ +int32BE :: Int32 -> FixedPrim 4 +int32BE = word32BE . fromIntegral + +-- | @'word32LE' . 'fromIntegral'@ +int32LE :: Int32 -> FixedPrim 4 +int32LE = word32LE . fromIntegral + +-- | @\bo -> 'word64' bo . 'fromIntegral'@ +int64 :: ByteOrder -> Int64 -> FixedPrim 8 +int64 bo = word64 bo . fromIntegral + +-- | @'word64Native' . 'fromIntegral'@ +int64Native :: Int64 -> FixedPrim 8 +int64Native = word64Native . fromIntegral + +-- | @'word64BE' . 'fromIntegral'@ +int64BE :: Int64 -> FixedPrim 8 +int64BE = word64BE . fromIntegral + +-- | @'word64LE' . 'fromIntegral'@ +int64LE :: Int64 -> FixedPrim 8 +int64LE = word64LE . fromIntegral + +-- | Fixed-width primitive that writes a 'Float' +-- in the specified byte order. +float :: ByteOrder -> Float -> FixedPrim 4 +float BigEndian = floatBE +float LittleEndian = floatLE + +-- | Fixed-width primitive that writes a 'Float' +-- in native byte order. +floatNative :: Float -> FixedPrim 4 +floatNative = float systemByteOrder + +-- | Fixed-width primitive that writes a 'Float' +-- in big-endian byte order. +floatBE :: Float -> FixedPrim 4 +floatBE !x = FixedPrim g + where + g v u s0 o = case floatToWord32 (Ptr v) (I# u) x of + IO h -> case h s0 of + (# s1, y #) -> + let FixedPrim f = word32BE y + in f v u s1 o + +-- | Fixed-width primitive that writes a 'Float' +-- in little-endian byte order. +floatLE :: Float -> FixedPrim 4 +floatLE !x = FixedPrim g + where + g v u s0 o = case floatToWord32 (Ptr v) (I# u) x of + IO h -> case h s0 of + (# s1, y #) -> + let FixedPrim f = word32LE y + in f v u s1 o + +-- | Fixed-width primitive that writes a 'Double' +-- in the specified byte order. +double :: ByteOrder -> Double -> FixedPrim 8 +double BigEndian = doubleBE +double LittleEndian = doubleLE + +-- | Fixed-width primitive that writes a 'Double' +-- in native byte order. +doubleNative :: Double -> FixedPrim 8 +doubleNative = double systemByteOrder + +-- | Fixed-width primitive that writes a 'Double' +-- in big-endian byte order. +doubleBE :: Double -> FixedPrim 8 +doubleBE !x = FixedPrim g + where + g v u s0 o = case doubleToWord64 (Ptr v) (I# u) x of + IO h -> case h s0 of + (# s1, y #) -> + let FixedPrim f = word64BE y + in f v u s1 o + +-- | Fixed-width primitive that writes a 'Double' +-- in little-endian byte order. +doubleLE :: Double -> FixedPrim 8 +doubleLE !x = FixedPrim g + where + g v u s0 o = case doubleToWord64 (Ptr v) (I# u) x of + IO h -> case h s0 of + (# s1, y #) -> + let FixedPrim f = word64LE y + in f v u s1 o + +-- | Bounded-width primitive that writes a 'Char' +-- according to the UTF-8 encoding. +charUtf8 :: Char -> BoundedPrim 4 +charUtf8 = \ch -> case fromIntegral (ord ch) of W# x -> wordUtf8 x + where + wordUtf8 :: Word# -> BoundedPrim 4 + wordUtf8 = + choose 0x7F p1 $ + choose 0x7FF p2 $ + choose 0xFFFF p3 $ + (\y -> liftFixedPrim (p4 y)) + {-# INLINE wordUtf8 #-} + + choose :: + forall v w . + (KnownNat v, KnownNat w) => + Word -> + (Word# -> FixedPrim v) -> + (Word# -> BoundedPrim w) -> + Word# -> BoundedPrim (Max w v) + choose = \t f g x -> pif (W# x <= t) (liftFixedPrim (f x)) (g x) + -- We have observed GHC v8.6.5 jumping on the 'False' branch + -- and falling through on the 'True' branch. We set up our + -- condition to favor lower character codes. + {-# INLINE choose #-} + + lsb :: + KnownNat n => + (Word# -> FixedPrim n) -> + Word# -> + FixedPrim (n + 1) + lsb = \p x -> p (uncheckedShiftRL# x 6#) &<> + word8 (W8# (plusWord# 0x80## (and# x 0x3F##))) + {-# INLINE lsb #-} + + p1 :: Word# -> FixedPrim 1 + p2 :: Word# -> FixedPrim 2 + p3 :: Word# -> FixedPrim 3 + p4 :: Word# -> FixedPrim 4 + + p1 x = word8 (W8# x) + p2 = lsb (\x -> word8 (W8# (plusWord# 0xC0## x))) + p3 = lsb (lsb (\x -> word8 (W8# (plusWord# 0xE0## x)))) + p4 = lsb (lsb (lsb (\x -> word8 (W8# (plusWord# 0xF0## x))))) + + {-# INLINE p1 #-} + {-# INLINE p2 #-} + {-# INLINE p3 #-} + {-# INLINE p4 #-} +{-# INLINE charUtf8 #-} + +-- | The bounded primitive implementing +-- `Proto3.Wire.Reverse.wordBase128LEVar`. +#if WORD_SIZE_IN_BITS < 64 +wordBase128LEVar :: Word -> BoundedPrim 5 +wordBase128LEVar (W# w) = word32Base128LEVar (W32# w) +#else +wordBase128LEVar :: Word -> BoundedPrim 10 +wordBase128LEVar (W# w) = word64Base128LEVar (W64# w) +#endif +{-# INLINE wordBase128LEVar #-} + +-- | Like 'wordBase128LEVar' but inlined, possibly bloating your code. On +-- the other hand, inlining an application to a constant may shrink your code. +#if WORD_SIZE_IN_BITS < 64 +wordBase128LEVar_inline :: Word -> BoundedPrim 5 +wordBase128LEVar_inline (W# w) = word32Base128LEVar_inline (W32# w) +#else +wordBase128LEVar_inline :: Word -> BoundedPrim 10 +wordBase128LEVar_inline (W# w) = word64Base128LEVar_inline (W64# w) +#endif +{-# INLINE wordBase128LEVar_inline #-} + +-- | The bounded primitive implementing +-- `Proto3.Wire.Reverse.word32Base128LEVar`. +word32Base128LEVar :: Word32 -> BoundedPrim 5 +word32Base128LEVar = word32Base128LEVar_inline +{-# INLINE word32Base128LEVar #-} + +-- | Like 'word32Base128LEVar' but inlined, which currently means +-- that it is just the same as 'word32Base128LEVar', which we inline. +word32Base128LEVar_inline :: Word32 -> BoundedPrim 5 +word32Base128LEVar_inline = \(W32# x0) -> + ( wordBase128LEVar_choose 1 wordBase128LE_p1 $ + wordBase128LEVar_choose 2 wordBase128LE_p2 $ + wordBase128LEVar_choose 3 wordBase128LE_p3 $ + wordBase128LEVar_choose 4 wordBase128LE_p4 $ + (\x -> liftFixedPrim (wordBase128LE_p5 0## x)) + ) x0 +{-# INLINE word32Base128LEVar_inline #-} + +wordBase128LEVar_choose :: + forall v w . + (KnownNat v, KnownNat w) => + Int -> + (Word# -> Word# -> FixedPrim v) -> + (Word# -> BoundedPrim w) -> + Word# -> BoundedPrim (Max w v) +wordBase128LEVar_choose = \d f g x -> + pif (W# x <= shiftL 1 (7 * d) - 1) (liftFixedPrim (f 0## x)) (g x) + -- We have observed GHC v8.6.5 jumping on the 'False' branch + -- and falling through on the 'True' branch. We set up our + -- condition to favor lower numeric values. +{-# INLINE wordBase128LEVar_choose #-} + +wordBase128LE_msb :: + forall n . + KnownNat n => + (Word# -> Word# -> FixedPrim n) -> + Word# -> Word# -> FixedPrim (n + 1) +wordBase128LE_msb = \p m x -> + p 0x80## x &<> word8 (W8# (or# m (uncheckedShiftRL# x s))) + where + !(I# s) = 7 * fromInteger (natVal' (proxy# :: Proxy# n)) +{-# INLINE wordBase128LE_msb #-} + +wordBase128LE_p1 :: Word# -> Word# -> FixedPrim 1 +wordBase128LE_p1 = \m x -> word8 (W8# (or# m x)) +{-# INLINE wordBase128LE_p1 #-} + +wordBase128LE_p2 :: Word# -> Word# -> FixedPrim 2 +wordBase128LE_p2 = wordBase128LE_msb wordBase128LE_p1 +{-# INLINE wordBase128LE_p2 #-} + +wordBase128LE_p3 :: Word# -> Word# -> FixedPrim 3 +wordBase128LE_p3 = wordBase128LE_msb wordBase128LE_p2 +{-# INLINE wordBase128LE_p3 #-} + +wordBase128LE_p4 :: Word# -> Word# -> FixedPrim 4 +wordBase128LE_p4 = wordBase128LE_msb wordBase128LE_p3 +{-# INLINE wordBase128LE_p4 #-} + +wordBase128LE_p5 :: Word# -> Word# -> FixedPrim 5 +wordBase128LE_p5 = wordBase128LE_msb wordBase128LE_p4 +{-# INLINE wordBase128LE_p5 #-} + +-- | Writes 1 or 2 base-128 digits in little-endian order; +-- in the 2-digit case the high bit of the containing byte of +-- the low digit is set, and the other byte has a clear high bit. +-- +-- WARNING: The argument is ASSUMED to be in [0 .. 2^14 - 1]. +word14Base128LEVar :: Word# -> BoundedPrim 2 +word14Base128LEVar = \x0 -> + ( wordBase128LEVar_choose 1 wordBase128LE_p1 $ + (\x -> liftFixedPrim (wordBase128LE_p2 0## x)) + ) x0 +{-# INLINE word14Base128LEVar #-} + +-- | Writes four base-128 digits, one per byte, with +-- the high bit of each byte set, in little-endian order. +-- +-- There is no requirement that the argument be @< 2^28@. +word28Base128LE :: Word# -> FixedPrim 4 +word28Base128LE = wordBase128LE_p4 0x80## +{-# INLINE word28Base128LE #-} + +-- | The bounded primitive implementing +-- `Proto3.Wire.Reverse.word64Base128LEVar`. +word64Base128LEVar :: Word64 -> BoundedPrim 10 +word64Base128LEVar = \(W64# x) -> + pif (W64# x <= fromIntegral (maxBound :: Word32)) + (word32Base128LEVar (fromIntegral (W64# x))) + (word64Base128LEVar_big x) +{-# INLINE word64Base128LEVar #-} + +-- | Like 'word64Base128LEVar' but inlined, possibly bloating your code. On +-- the other hand, inlining an application to a constant may shrink your code. +word64Base128LEVar_inline :: Word64 -> BoundedPrim 10 +word64Base128LEVar_inline = \(W64# x) -> + pif (W64# x <= fromIntegral (maxBound :: Word32)) + (word32Base128LEVar (fromIntegral (W64# x))) + (inline (word64Base128LEVar_big x)) +{-# INLINE word64Base128LEVar_inline #-} + +-- | The input must be at least 2^32. +word64Base128LEVar_big :: WORD64 -> BoundedPrim 10 +word64Base128LEVar_big x = pif (W64# x <= shiftL 1 60 - 1) p60 p64 + where + p60 = liftFixedPrim (word28Base128LE x32) &<> + word32Base128LEVar (W32# (shR 28)) + + p64 = ( liftFixedPrim (word28Base128LE x32) &<> + liftFixedPrim (word28Base128LE (shR 28)) ) &<> + word14Base128LEVar (shR 56) + + x32 = case fromIntegral (W64# x) of W32# y -> y + + shR s = case fromIntegral (shiftR (W64# x) s) of W32# y -> y +{-# NOINLINE word64Base128LEVar_big #-} + +-- | The analog of `Proto3.Wire.Reverse.vectorBuildR` for when fixed-width +-- primitives encode the elements of the vector. In this special case we +-- can predict the overall length. +vectorFixedPrim :: + forall w v a . + (KnownNat w, Data.Vector.Generic.Vector v a) => + (a -> FixedPrim w) -> + v a -> + BuildR +vectorFixedPrim f = etaBuildR $ \v -> + let op acc x = acc <> unsafeBuildBoundedPrim (liftFixedPrim (f x)) + in ensure (w * Data.Vector.Generic.length v) (foldlRVector op mempty v) + where + w = fromInteger (natVal' (proxy# :: Proxy# w)) +{-# INLINE vectorFixedPrim #-} diff --git a/src/Proto3/Wire/Reverse/Width.hs b/src/Proto3/Wire/Reverse/Width.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Reverse/Width.hs @@ -0,0 +1,113 @@ +{- + Copyright 2020 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Augmentations to type classes such as 'Semigroup' and 'Monoid' that may +-- be used to track the type-level width information of builder primitives. +module Proto3.Wire.Reverse.Width + ( AssocPlusNat(..) + , CommPlusNat(..) + , PChoose(..) + , Max + , AssocMaxNat(..) + , CommMaxNat(..) + ) where + +import Data.Type.Bool (If) +import GHC.Exts (Proxy#) +import GHC.TypeLits (type (<=?), type (+)) +import Parameterized.Data.Semigroup (PNullary) + +-- | Associativity of '+' in type parameters. +class AssocPlusNat n u v w + where + assocLPlusNat :: + Proxy# '(u, v, w) -> + PNullary n (u + (v + w)) -> + PNullary n ((u + v) + w) + + assocRPlusNat :: + Proxy# '(u, v, w) -> + PNullary n ((u + v) + w) -> + PNullary n (u + (v + w)) + +-- | Commutativity of '+' in type parameters. +class CommPlusNat n u v + where + commPlusNat :: + Proxy# '(u, v) -> + PNullary n (u + v) -> + PNullary n (v + u) + +-- | Chooses between alternatives based on a condition, +-- adjusting a type-level parameter appropriately. +-- +-- Note that while this type class makes sense for bounded builder primitives, +-- it should not be instantiated for fixed-width primitives of differing +-- widths (at least, not without padding to equalize the widths) because +-- the choice between alternatives introduces a run-time variation in width. +-- Instead please use ordinary `Data.Bool.bool` or @if _ then _ else _@. +class PChoose n f t w | f t -> w + where + -- | Like `Data.Bool.bool`, chooses the first argument on 'False' + -- and the second on 'True', either way promoting the type-level + -- `GHC.TypeLits.Nat` to the larger of the given `GHC.TypeLits.Nat`s. + -- + -- Defaults to the natural implementation in terms of 'pif'. + pbool :: PNullary n f -> PNullary n t -> Bool -> PNullary n w + pbool f t b = pif b t f + {-# INLINE CONLIKE pbool #-} + + -- | Like @if _ then _ else@, chooses the first argument on 'True' + -- and the second on 'False', either way promoting the type-level + -- `GHC.TypeLits.Nat` to the larger of the given `GHC.TypeLits.Nat`s. + -- + -- Defaults to the natural implementation in terms of 'pbool'. + pif :: Bool -> PNullary n t -> PNullary n f -> PNullary n w + pif c t e = pbool e t c + {-# INLINE CONLIKE pif #-} + + {-# MINIMAL pbool | pif #-} + +-- | The larger of two `GHC.TypeLits.Nat`s. +type Max u v = If (v <=? u) u v + +-- | Associativity of 'Max' in type parameters. +class AssocMaxNat n u v w + where + assocLMaxNat :: + Proxy# '(u, v, w) -> + PNullary n (Max u (Max v w)) -> + PNullary n (Max (Max u v) w) + + assocRMaxNat :: + Proxy# '(u, v, w) -> + PNullary n (Max (Max u v) w) -> + PNullary n (Max u (Max v w)) + +-- | Commutativity of 'Max' in type parameters. +class CommMaxNat n u v + where + commMaxNat :: + Proxy# '(u, v) -> + PNullary n (Max u v) -> + PNullary n (Max v u) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,8 +17,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} + module Main where +import Control.Arrow ( (&&&), first, second ) +import Control.Monad ( guard, void ) +import Control.Monad.Trans.State ( StateT(..) ) +import qualified Data.Bits as Bits import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Builder.Internal as BBI @@ -26,10 +32,16 @@ import Data.Maybe ( fromMaybe ) import Data.Monoid ( (<>) ) import Data.Int +import Data.List ( group ) import qualified Data.Text.Lazy as T +import qualified Data.Vector as V +import Data.Word ( Word8, Word64 ) +import Foreign ( sizeOf ) import Proto3.Wire import qualified Proto3.Wire.Builder as Builder +import qualified Proto3.Wire.Reverse as Reverse +import qualified Proto3.Wire.Reverse.Prim as Prim import qualified Proto3.Wire.Encode as Encode import qualified Proto3.Wire.Decode as Decode @@ -44,7 +56,9 @@ main = do Test.DocTest.doctest [ "-isrc" + , "-fobject-code" , "src/Proto3/Wire/Builder.hs" + , "src/Proto3/Wire/Reverse.hs" , "src/Proto3/Wire/Encode.hs" , "src/Proto3/Wire/Decode.hs" ] @@ -53,8 +67,12 @@ tests :: TestTree tests = testGroup "Tests" [ roundTripTests , buildSingleChunk + , buildRBufferSizes + , strictByteString + , lazyByteString , decodeNonsense , varIntHeavyTests + , packedLargeTests ] data StringOrInt64 = TString T.Text | TInt64 Int64 @@ -63,7 +81,7 @@ instance QC.Arbitrary StringOrInt64 where arbitrary = QC.oneof [ TString . T.pack <$> QC.arbitrary, TInt64 <$> QC.arbitrary ] --- this just stress tesses the fancy varint encodings with more randomness +-- This just stress tests the fancy varint encodings with more randomness. varIntHeavyTests :: TestTree varIntHeavyTests = adjustOption (const $ QC.QuickCheckTests 10000) $ roundTrip "varInt uint test" @@ -123,14 +141,46 @@ 0 `at` fieldNumber 1)) `at` fieldNumber 1) - , roundTrip "embeddedList" + , roundTrip "embeddedListPackedVarints" (Encode.embedded (fieldNumber 1) . + Encode.packedVarints (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedVarints [] + `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedFixed32" + (Encode.embedded (fieldNumber 1) . Encode.packedFixed32 (fieldNumber 1)) (fmap (fromMaybe [0,1,2,3,4]) (Decode.embedded (one Decode.packedFixed32 [] `at` fieldNumber 1)) `at` fieldNumber 1) + , roundTrip "embeddedListPackedFixed64" + (Encode.embedded (fieldNumber 1) . + Encode.packedFixed64 (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFixed64 [] + `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedFloats" + (Encode.embedded (fieldNumber 1) . + Encode.packedFloats (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFloats [] + `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "embeddedListPackedDoubles" + (Encode.embedded (fieldNumber 1) . + Encode.packedDoubles (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedDoubles [] + `at` + fieldNumber 1)) + `at` fieldNumber 1) , roundTrip "embeddedListUnpacked" (Encode.embedded (fieldNumber 1) . (foldMap . Encode.int32) (fieldNumber 1)) @@ -185,7 +235,7 @@ Right x' -> x === x' buildSingleChunk :: TestTree -buildSingleChunk = HU.testCase "Builder creates a single chunk" $ do +buildSingleChunk = HU.testCase "Legacy Builder creates a single chunk" $ do let chunks = length . BL.toChunks . Builder.toLazyByteString huge = B.replicate (BBI.maximalCopySize + 16) 1 @@ -197,7 +247,486 @@ HU.assertBool "single chunk (strict)" $ chunks huge2 == 1 HU.assertBool "single chunk (lazy)" $ chunks hugeL2 == 1 +parseBytes :: Int64 -> StateT BL.ByteString Maybe BL.ByteString +parseBytes n = StateT $ \bl -> do + let (before, after) = BL.splitAt n bl + guard (BL.length before == n) + pure (before, after) + +-- | Parses a big-endian 64-bit unsigned integer. +parseWord64BE :: StateT BL.ByteString Maybe Word64 +parseWord64BE = do + let be n bl = maybe n (j n) (BL.uncons bl) + j n (h, t) = be (256 * n + fromIntegral h) t + be 0 <$> parseBytes 8 + +-- | Consumes and returns the longest prefix whose bytes +-- all satisfy the given predicate. Never fails. +parseWhile :: (Word8 -> Bool) -> StateT BL.ByteString Maybe BL.ByteString +parseWhile p = StateT (Just . BL.span p) + +-- | Run-length encode lazy a 'BL.ByteString' +-- for concise display in test results. +rle :: BL.ByteString -> [(Int, Word8)] +rle = map (length &&& head) . group . BL.unpack + +-- | Please adjust this expected size of the metadata header +-- to match that expected of the current implementation. +buildRMeta :: Int +buildRMeta = 2 * sizeOf (undefined :: Word) + sizeOf (undefined :: Double) + +buildRSmallChunkSize :: Int +buildRSmallChunkSize = BBI.smallChunkSize - buildRMeta + +buildRDefaultChunkSize :: Int +buildRDefaultChunkSize = BBI.defaultChunkSize - buildRMeta + +-- | Encodes the given 64-bit unsigned integer in big-endian format. +encodeWord64BE :: Word64 -> B.ByteString +encodeWord64BE = B.pack . go 8 + where + go n w + | n <= 0 = [] + | otherwise = fromIntegral (Bits.shiftR w (8 * (n - 1))) : go (n - 1) w + +-- | Writes the given byte into all the previously-unused +-- bytes in the current buffer. +fillUnused :: Word8 -> Reverse.BuildR +fillUnused = fillUnusedExcept 0 + +-- | Like 'fillUnused', but writes fewer bytes in order to leave +-- the specified number of bytes unused, unless we start with fewer, +-- in which case there is no change at all. +fillUnusedExcept :: Int -> Word8 -> Reverse.BuildR +fillUnusedExcept unusedRemaining w8 = Reverse.testWithUnused $ \u -> + foldMap (const (Reverse.word8 w8)) [unusedRemaining + 1 .. u] +{-# NOINLINE fillUnusedExcept #-} + -- In case rewrite rules would interfere with buffer boundaries, + -- which may be fine normally, we forbid inlining of this probe. + +buildRBufferSizes :: TestTree +buildRBufferSizes = HU.testCase "BuildR buffer sizes" $ do + let builder1 m = Reverse.ensure (max 8 m) $ Reverse.testWithUnused $ \u -> + Reverse.word64BE (fromIntegral u) <> fillUnusedExcept 8 7 + {-# NOINLINE builder1 #-} + + let builder3 = + builder1 (buildRDefaultChunkSize + 1) <> builder1 0 <> builder1 0 + + let encodedBytes :: BL.ByteString + encodedBytes = Reverse.toLazyByteString builder3 + + let parseBuffer :: StateT BL.ByteString Maybe Word64 + parseBuffer = do + n <- parseWord64BE + _ <- parseBytes (max 0 (fromIntegral n - 8)) + pure n + + let parseBuffer3 :: StateT BL.ByteString Maybe (Word64, Word64, Word64) + parseBuffer3 = do + x <- parseBuffer + y <- parseBuffer + z <- parseBuffer + pure (x, y, z) + + let actual, expected :: Maybe ((Word64, Word64, Word64), [(Int, Word8)]) + actual = second rle <$> runStateT parseBuffer3 encodedBytes + expected = Just ((t, s, f), []) + -- We build in reverse but parser forward; therefore + -- the initial allocation is the final component. + where + t = fromIntegral buildRDefaultChunkSize + 1 + s = fromIntegral buildRDefaultChunkSize + f = fromIntegral buildRSmallChunkSize + + let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes) + HU.assertEqual msg expected actual + +strictByteString :: TestTree +strictByteString = HU.testCase "Strict ByteString BuildR" $ do + -- Because the initial buffer has a distinctive size we can use + -- to distinguish it from other buffers, we start with a string + -- that does not fit in that buffer, so that we can check that + -- the buffer is reused as-is after those strings, not reallocated. + let builder1 = Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate (buildRSmallChunkSize + 1) 10 <> + encodeWord64BE (fromIntegral u) + {-# NOINLINE builder1 #-} + + -- Then we write strings that do fit within the initial buffer. + let builder2 = Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 20 <> encodeWord64BE (fromIntegral u) + {-# NOINLINE builder2 #-} + + let builder3 = Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 30 <> encodeWord64BE (fromIntegral u) + {-# NOINLINE builder3 #-} + + -- Then we check the just-enough-room case, which incidentally + -- ensures that we use enough of the initial buffer that it + -- will not be recycled. + let builder4 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 40 <> encodeWord64BE (fromIntegral u) ) + <> fillUnusedExcept 11 (0xD0 - 4) <> + ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder4 #-} + + -- Then the case of the almost-full-buffer with not quite enough room. + let builder5 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 50 <> encodeWord64BE (fromIntegral u) ) + <> fillUnusedExcept 10 (0xD0 - 5) <> + ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder5 #-} + + -- Then the full-buffer case. + let builder6 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 60 <> encodeWord64BE (fromIntegral u) ) + <> fillUnused (0xD0 - 6) <> + ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder6 #-} + + -- Check final unused. + let builder7 = ( Reverse.testWithUnused $ \u -> Reverse.byteString $ + B.replicate 3 70 <> encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder7 #-} + + let buildAll = builder7 <> builder6 <> builder5 <> + builder4 <> builder3 <> builder2 <> builder1 + + let encodedBytes :: BL.ByteString + encodedBytes = Reverse.toLazyByteString buildAll + + let parseFixed :: Int64 -> Word8 -> StateT BL.ByteString Maybe () + parseFixed n w = do + bl <- parseBytes n + guard (BL.all (w ==) bl) + + let parsePad :: Word8 -> StateT BL.ByteString Maybe () + parsePad = void . parseWhile . (==) + + let parseAll :: StateT BL.ByteString Maybe + ( Word64, (Word64, Word64), (Word64, Word64), + (Word64, Word64), Word64, Word64, Word64 ) + parseAll = do + parseFixed 3 70 + u7 <- parseWord64BE + + parseFixed 3 60 + u6B <- parseWord64BE + parsePad (0xD0 - 6) + u6A <- parseWord64BE + + parseFixed 3 50 + u5B <- parseWord64BE + parsePad (0xD0 - 5) + u5A <- parseWord64BE + + parseFixed 3 40 + u4B <- parseWord64BE + parsePad (0xD0 - 4) + u4A <- parseWord64BE + + parseFixed 3 30 + u3 <- parseWord64BE + + parseFixed 3 20 + u2 <- parseWord64BE + + parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 10 + u1 <- parseWord64BE + + pure (u7, (u6B, u6A), (u5B, u5A), (u4B, u4A), u3, u2, u1) + + let actual, expected :: + Maybe ( ( Word64, (Word64, Word64), (Word64, Word64) + , (Word64, Word64), Word64, Word64, Word64 ) + , [(Int, Word8)] + ) + actual = second rle <$> runStateT parseAll encodedBytes + expected = Just ((u7, (u6B,u6A), (u5B,u5A), (u4B, u4A), u3, u2, u1), []) + where + u1 = fromIntegral $ buildRSmallChunkSize -- before we wrote anything + u2 = fromIntegral $ buildRSmallChunkSize -- bypassed unused buffer + u3 = fromIntegral $ buildRSmallChunkSize - 11 -- after second write + u4A = fromIntegral $ buildRSmallChunkSize - 22 -- after third write + u4B = 11 -- after padding + u5A = 0 -- buffer full from previous write + u5B = 10 -- after padding + u6A = fromIntegral $ buildRDefaultChunkSize + -- new buffer after bypassing used buffer + u6B = 0 -- buffer completely full + u7 = fromIntegral $ buildRDefaultChunkSize + -- new buffer after bypassing used buffer + + let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes) + HU.assertEqual msg expected actual + +lazyByteString :: TestTree +lazyByteString = HU.testCase "Strict ByteString BuildR" $ do + -- Because the initial buffer has a distinctive size we can use + -- to distinguish it from other buffers, we start with a string + -- whose chunks do not fit in that buffer, so that we can check that + -- the buffer is reused as-is after those strings, not reallocated. + let builder1 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 12 ) <> + BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 11 ) <> + BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1) 10 <> + encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder1 #-} + + -- Then we write a string whose rightmost two chunks do fit + -- within the initial buffer but whose leftmost chunk does + -- not fit after the others are written. We ensure that most + -- of the initial buffer is consumed because otherwise it might + -- be recycled, which would prevent us from detecting that some + -- chunks were actually written to the buffer. + let builder2 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict ( B.replicate 3 22 ) <> + BL.fromStrict ( B.replicate (buildRSmallChunkSize + 1 - 14) 21 ) <> + BL.fromStrict ( B.replicate 3 20 <> encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder2 #-} + + -- And a string that fits entirely within the second buffer. + let builder3 = Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict ( B.replicate 3 32 ) <> + BL.fromStrict ( B.replicate 3 31 ) <> + BL.fromStrict ( B.replicate 3 30 <> encodeWord64BE (fromIntegral u) ) + {-# NOINLINE builder3 #-} + + -- Then we check the just-enough-room case. + let builder4 = + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (B.replicate 3 41) <> + BL.fromStrict (B.replicate 3 40 <> encodeWord64BE (fromIntegral u)) + ) <> fillUnusedExcept 14 (0xD0 - 4) <> + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (encodeWord64BE (fromIntegral u)) + ) + {-# NOINLINE builder4 #-} + + -- Then the case of the almost-full-buffer with not quite enough room. + let builder5 = + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (B.replicate 3 51) <> + BL.fromStrict (B.replicate 3 50 <> encodeWord64BE (fromIntegral u)) + ) <> fillUnusedExcept 13 (0xD0 - 5) <> + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (encodeWord64BE (fromIntegral u)) + ) + {-# NOINLINE builder5 #-} + + -- Then the full-buffer case. + let builder6 = + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (B.replicate 3 61) <> + BL.fromStrict (B.replicate 3 60 <> encodeWord64BE (fromIntegral u)) + ) <> fillUnused (0xD0 - 6) <> + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (encodeWord64BE (fromIntegral u)) + ) + {-# NOINLINE builder6 #-} + + -- Check final unused. + let builder7 = + ( Reverse.testWithUnused $ \u -> Reverse.lazyByteString $ + BL.fromStrict (B.replicate 3 70 <> encodeWord64BE (fromIntegral u)) + ) + {-# NOINLINE builder7 #-} + + let buildAll = builder7 <> builder6 <> builder5 <> + builder4 <> builder3 <> builder2 <> builder1 + + let encodedBytes :: BL.ByteString + encodedBytes = Reverse.toLazyByteString buildAll + + let parseFixed :: Int64 -> Word8 -> StateT BL.ByteString Maybe () + parseFixed n w = do + bl <- parseBytes n + guard (BL.all (w ==) bl) + + let parsePad :: Word8 -> StateT BL.ByteString Maybe () + parsePad = void . parseWhile . (==) + + let parseAll :: StateT BL.ByteString Maybe + ( Word64, (Word64, Word64), (Word64, Word64), + (Word64, Word64), Word64, Word64, Word64 ) + parseAll = do + parseFixed 3 70 + u7 <- parseWord64BE + + parseFixed 3 61 + parseFixed 3 60 + u6B <- parseWord64BE + parsePad (0xD0 - 6) + u6A <- parseWord64BE + + parseFixed 3 51 + parseFixed 3 50 + u5B <- parseWord64BE + parsePad (0xD0 - 5) + u5A <- parseWord64BE + + parseFixed 3 41 + parseFixed 3 40 + u4B <- parseWord64BE + parsePad (0xD0 - 4) + u4A <- parseWord64BE + + parseFixed 3 32 + parseFixed 3 31 + parseFixed 3 30 + u3 <- parseWord64BE + + parseFixed 3 22 + parseFixed (fromIntegral (buildRSmallChunkSize + 1 - 14)) 21 + parseFixed 3 20 + u2 <- parseWord64BE + + parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 12 + parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 11 + parseFixed (fromIntegral (buildRSmallChunkSize + 1)) 10 + u1 <- parseWord64BE + + pure (u7, (u6B, u6A), (u5B, u5A), (u4B, u4A), u3, u2, u1) + + let actual, expected :: + Maybe ( ( Word64, (Word64, Word64), (Word64, Word64) + , (Word64, Word64), Word64, Word64, Word64 ) + , [(Int, Word8)] + ) + actual = second rle <$> runStateT parseAll encodedBytes + expected = Just ((u7, (u6B,u6A), (u5B,u5A), (u4B, u4A), u3, u2, u1), []) + where + u1 = fromIntegral $ buildRSmallChunkSize -- before we wrote anything + u2 = fromIntegral $ buildRSmallChunkSize -- bypassed unused buffer + u3 = fromIntegral $ buildRDefaultChunkSize -- after second write + u4A = fromIntegral $ buildRDefaultChunkSize - 17 -- after third write + u4B = 14 -- after padding + u5A = 0 -- buffer full from previous write + u5B = 13 -- after padding + u6A = fromIntegral $ buildRDefaultChunkSize + -- new buffer after bypassing used buffer + u6B = 0 -- buffer completely full + u7 = fromIntegral $ buildRDefaultChunkSize + -- new buffer after bypassing used buffer + + let msg = "run-length encoding of built bytes: " ++ show (rle encodedBytes) + HU.assertEqual msg expected actual + decodeNonsense :: TestTree decodeNonsense = HU.testCase "Decoding a nonsensical string fails." $ do let decoded = Decode.parse (one Decode.fixed64 0 `at` fieldNumber 1) "test" HU.assertBool "decode fails" $ isLeft decoded + +packedLargeTests :: TestTree +packedLargeTests = testGroup "Test packed encoders on large inputs" + [ packedVarints_large + , packedVarintsV_large + , packedBoolsV_large + , packedFixed32_large + , packedFixed32V_large + , packedFixed64_large + , packedFixed64V_large + , packedFloats_large + , packedFloatsV_large + , packedDoubles_large + , packedDoublesV_large + ] + +packedVarints_large :: TestTree +packedVarints_large = HU.testCase "Large packedVarints" $ do + let count = 40000 + encoded = Encode.toLazyByteString (Encode.packedVarints 13 [1 .. count]) + decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [1 .. count]) decoded + +packedVarintsV_large :: TestTree +packedVarintsV_large = HU.testCase "Large packedVarintsV" $ do + let count = 40000 + encoded = Encode.toLazyByteString + (Encode.packedVarintsV (1 +) 13 (V.fromList [1 .. count])) + decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +packedBoolsV_large :: TestTree +packedBoolsV_large = HU.testCase "Large packedBoolsV" $ do + let count = 40000 :: Int + values = map (flip Bits.testBit 0) [1 .. count] + encoded = Encode.toLazyByteString + (Encode.packedBoolsV not 13 (V.fromList values)) + decoded = Decode.parse (one Decode.packedVarints [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right (map (fromEnum . not) values)) decoded + +packedFixed32_large :: TestTree +packedFixed32_large = HU.testCase "Large packedFixed32" $ do + let count = 40000 + encoded = Encode.toLazyByteString (Encode.packedFixed32 13 [1 .. count]) + decoded = Decode.parse (one Decode.packedFixed32 [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [1 .. count]) decoded + +packedFixed32V_large :: TestTree +packedFixed32V_large = HU.testCase "Large packedFixed32V" $ do + let count = 40000 + encoded = Encode.toLazyByteString + (Encode.packedFixed32V (1 +) 13 (V.fromList [1 .. count])) + decoded = Decode.parse (one Decode.packedFixed32 [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +packedFixed64_large :: TestTree +packedFixed64_large = HU.testCase "Large packedFixed64" $ do + let count = 40000 + encoded = Encode.toLazyByteString (Encode.packedFixed64 13 [1 .. count]) + decoded = Decode.parse (one Decode.packedFixed64 [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [1 .. count]) decoded + +packedFixed64V_large :: TestTree +packedFixed64V_large = HU.testCase "Large packedFixed64V" $ do + let count = 40000 + encoded = Encode.toLazyByteString + (Encode.packedFixed64V (1 +) 13 (V.fromList [1 .. count])) + decoded = Decode.parse (one Decode.packedFixed64 [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +packedFloats_large :: TestTree +packedFloats_large = HU.testCase "Large packedFloats" $ do + let count = 40000 + encoded = Encode.toLazyByteString (Encode.packedFloats 13 [1 .. count]) + decoded = Decode.parse (one Decode.packedFloats [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [1 .. count]) decoded + +packedFloatsV_large :: TestTree +packedFloatsV_large = HU.testCase "Large packedFloatsV" $ do + let count = 40000 + encoded = Encode.toLazyByteString + (Encode.packedFloatsV (1 +) 13 (V.fromList [1 .. count])) + decoded = Decode.parse (one Decode.packedFloats [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded + +packedDoubles_large :: TestTree +packedDoubles_large = HU.testCase "Large packedDoubles" $ do + let count = 40000 + encoded = Encode.toLazyByteString (Encode.packedDoubles 13 [1 .. count]) + decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [1 .. count]) decoded + +packedDoublesV_large :: TestTree +packedDoublesV_large = HU.testCase "Large packedDoublesV" $ do + let count = 40000 + encoded = Encode.toLazyByteString + (Encode.packedDoublesV (1 +) 13 (V.fromList [1 .. count])) + decoded = Decode.parse (one Decode.packedDoubles [] `at` fieldNumber 13) + (BL.toStrict encoded) + HU.assertEqual "round trip" (Right [2 .. count + 1]) decoded