composewell/streamly
1
1
Fork 0
mirror of https://github.com/composewell/streamly.git synced 2024-08-17 07:20:36 +03:00
Code Issues Packages Projects Releases Wiki Activity

Rename serialize/deserialize/size of Serialize class

Browse Source
This commit is contained in:
Harendra Kumar 2023-11-25 23:50:58 +05:30
parent 1efeed403b
commit 13581bfec1
10 changed files with 190 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
benchmark/Streamly/Benchmark/Data/Serialize.hs
View File

@ -49,8 +49,8 @@ import Streamly.Benchmark.Data.Serialize.RecNonCompatible
#else
#define SERIALIZE_CLASS Serialize
#define DERIVE_CLASS(typ) $(deriveSerialize [d|instance Serialize typ|])
#define SERIALIZE_OP serialize
#define DESERIALIZE_OP deserialize
#define SERIALIZE_OP serializeAt
#define DESERIALIZE_OP deserializeAt
#endif
-------------------------------------------------------------------------------
@ -288,7 +288,7 @@ getSize :: forall a. SERIALIZE_CLASS a => a -> Int
#ifdef USE_UNBOX
getSize _ = sizeOf (Proxy :: Proxy a)
#else
getSize = size 0
getSize = addSizeTo 0
#endif
-------------------------------------------------------------------------------

6
core/src/Streamly/Data/MutByteArray.hs
View File

@ -75,9 +75,9 @@ module Streamly.Data.MutByteArray
-- Deriving Serialize
, SerializeConfig
, serializeConfig
, inlineSize
, inlineSerialize
, inlineDeserialize
, inlineAddSizeTo
, inlineSerializeAt
, inlineDeserializeAt
, deriveSerialize
, deriveSerializeWith

7
core/src/Streamly/Internal/Data/Array.hs
View File

@ -561,9 +561,9 @@ streamFold f arr = f (A.read arr)
encodeAs :: forall a. Serialize a => PinnedState -> a -> Array Word8
encodeAs ps a =
unsafeInlineIO $ do
let len = Serialize.size 0 a
let len = Serialize.addSizeTo 0 a
mbarr <- MBA.newBytesAs ps len
off <- Serialize.serialize 0 mbarr a
off <- Serialize.serializeAt 0 mbarr a
assertM(len == off)
pure $ Array mbarr 0 off
@ -584,6 +584,7 @@ pinnedSerialize = encodeAs Pinned
deserialize :: Serialize a => Array Word8 -> a
deserialize arr@(Array {..}) = unsafeInlineIO $ do
let lenArr = length arr
(off, val) <- Serialize.deserialize arrStart arrContents (arrStart + lenArr)
(off, val) <-
Serialize.deserializeAt arrStart arrContents (arrStart + lenArr)
assertM(off == arrStart + lenArr)
pure val

117
core/src/Streamly/Internal/Data/MutByteArray.hs
View File

@ -88,73 +88,73 @@ import Streamly.Internal.Data.Unbox.TH
-- $(Serialize.deriveSerialize ''Maybe)
instance Serialize a => Serialize (Maybe a) where
{-# INLINE size #-}
size acc x =
{-# INLINE addSizeTo #-}
addSizeTo acc x =
case x of
Nothing -> (acc + 1)
Just field0 -> (size (acc + 1)) field0
Just field0 -> (addSizeTo (acc + 1)) field0
{-# INLINE deserialize #-}
deserialize initialOffset arr endOffset = do
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
{-# INLINE deserializeAt #-}
deserializeAt initialOffset arr endOffset = do
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
case tag :: Word8 of
0 -> pure (i0, Nothing)
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, Just a0)
_ -> error "Found invalid tag while peeking (Maybe a)"
{-# INLINE serialize #-}
serialize initialOffset arr val =
{-# INLINE serializeAt #-}
serializeAt initialOffset arr val =
case val of
Nothing -> do
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
pure i0
Just field0 -> do
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
-- $(Serialize.deriveSerialize ''Either)
instance (Serialize a, Serialize b) => Serialize (Either a b) where
{-# INLINE size #-}
size acc x =
{-# INLINE addSizeTo #-}
addSizeTo acc x =
case x of
Left field0 -> (size (acc + 1)) field0
Right field0 -> (size (acc + 1)) field0
Left field0 -> (addSizeTo (acc + 1)) field0
Right field0 -> (addSizeTo (acc + 1)) field0
{-# INLINE deserialize #-}
deserialize initialOffset arr endOffset = do
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
{-# INLINE deserializeAt #-}
deserializeAt initialOffset arr endOffset = do
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
case tag :: Word8 of
0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, Left a0)
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, Right a0)
_ -> error "Found invalid tag while peeking (Either a b)"
{-# INLINE serialize #-}
serialize initialOffset arr val =
{-# INLINE serializeAt #-}
serializeAt initialOffset arr val =
case val of
Left field0 -> do
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
Right field0 -> do
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
instance Serialize (Proxy a) where
{-# INLINE size #-}
size acc _ = (acc + 1)
{-# INLINE addSizeTo #-}
addSizeTo acc _ = (acc + 1)
{-# INLINE deserialize #-}
deserialize initialOffset _ _ = pure ((initialOffset + 1), Proxy)
{-# INLINE deserializeAt #-}
deserializeAt initialOffset _ _ = pure ((initialOffset + 1), Proxy)
{-# INLINE serialize #-}
serialize initialOffset _ _ = pure (initialOffset + 1)
{-# INLINE serializeAt #-}
serializeAt initialOffset _ _ = pure (initialOffset + 1)
--------------------------------------------------------------------------------
-- Integer
@ -168,39 +168,39 @@ data LiftedInteger
-- $(Serialize.deriveSerialize ''LiftedInteger)
instance Serialize LiftedInteger where
{-# INLINE size #-}
size acc x =
{-# INLINE addSizeTo #-}
addSizeTo acc x =
case x of
LIS field0 -> (size (acc + 1)) field0
LIP field0 -> (size (acc + 1)) field0
LIN field0 -> (size (acc + 1)) field0
LIS field0 -> (addSizeTo (acc + 1)) field0
LIP field0 -> (addSizeTo (acc + 1)) field0
LIN field0 -> (addSizeTo (acc + 1)) field0
{-# INLINE deserialize #-}
deserialize initialOffset arr endOffset = do
(i0, tag) <- ((deserialize initialOffset) arr) endOffset
{-# INLINE deserializeAt #-}
deserializeAt initialOffset arr endOffset = do
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
case tag :: Word8 of
0 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, LIS a0)
1 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, LIP a0)
2 -> do (i1, a0) <- ((deserialize i0) arr) endOffset
2 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
pure (i1, LIN a0)
_ -> error "Found invalid tag while peeking (LiftedInteger)"
{-# INLINE serialize #-}
serialize initialOffset arr val =
{-# INLINE serializeAt #-}
serializeAt initialOffset arr val =
case val of
LIS field0 -> do
i0 <- ((serialize initialOffset) arr) (0 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
LIP field0 -> do
i0 <- ((serialize initialOffset) arr) (1 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
LIN field0 -> do
i0 <- ((serialize initialOffset) arr) (2 :: Word8)
i1 <- ((serialize i0) arr) field0
i0 <- ((serializeAt initialOffset) arr) (2 :: Word8)
i1 <- ((serializeAt i0) arr) field0
pure i1
#if __GLASGOW_HASKELL__ >= 900
@ -240,11 +240,12 @@ unliftInteger (LIN (Array (MutByteArray x) _ _)) =
#endif
instance Serialize Integer where
{-# INLINE size #-}
size i a = size i (liftInteger a)
{-# INLINE addSizeTo #-}
addSizeTo i a = addSizeTo i (liftInteger a)
{-# INLINE deserialize #-}
deserialize off arr end = fmap unliftInteger <$> deserialize off arr end
{-# INLINE deserializeAt #-}
deserializeAt off arr end =
fmap unliftInteger <$> deserializeAt off arr end
{-# INLINE serialize #-}
serialize off arr val = serialize off arr (liftInteger val)
{-# INLINE serializeAt #-}
serializeAt off arr val = serializeAt off arr (liftInteger val)

32
core/src/Streamly/Internal/Data/Serialize/TH.hs
View File

@ -50,7 +50,7 @@ import Streamly.Internal.Data.Serialize.TH.RecHeader
--------------------------------------------------------------------------------
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
exprGetSize acc (i, _) = [|size $(acc) $(varE (mkFieldName i))|]
exprGetSize acc (i, _) = [|addSizeTo $(acc) $(varE (mkFieldName i))|]
getTagSize :: Int -> Int
getTagSize numConstructors
@ -170,9 +170,9 @@ mkSizeDec (SerializeConfig {..}) headTy cons = do
pure
( maybe
[]
(\x -> [PragmaD (InlineP 'size x FunLike AllPhases)])
(\x -> [PragmaD (InlineP 'addSizeTo x FunLike AllPhases)])
cfgInlineSize
++ [FunD 'size [Clause [] (NormalB sizeOfMethod) []]]
++ [FunD 'addSizeTo [Clause [] (NormalB sizeOfMethod) []]]
)
--------------------------------------------------------------------------------
@ -192,7 +192,7 @@ mkDeserializeExpr True False headTy tyOfTy =
conLen <- newName "conLen"
off1 <- newName "off1"
[|do ($(varP off1), $(varP conLen) :: Word8) <-
deserialize
deserializeAt
$(varE _initialOffset)
$(varE _arr)
$(varE _endOffset)
@ -212,7 +212,7 @@ mkDeserializeExpr True False headTy tyOfTy =
[|($(litIntegral lenCname) == $(varE conLen))
&& $(xorCmp tag off _arr)|]
[|let $(varP (makeI 0)) = $(varE off) + $(litIntegral lenCname)
in $(mkDeserializeExprOne 'deserialize con)|]
in $(mkDeserializeExprOne 'deserializeAt con)|]
mkDeserializeExpr False False headTy tyOfTy =
case tyOfTy of
@ -223,7 +223,7 @@ mkDeserializeExpr False False headTy tyOfTy =
TheType con ->
letE
[valD (varP (mkName "i0")) (normalB (varE _initialOffset)) []]
(mkDeserializeExprOne 'deserialize con)
(mkDeserializeExprOne 'deserializeAt con)
-- Sum type
MultiType cons -> do
let lenCons = length cons
@ -231,7 +231,7 @@ mkDeserializeExpr False False headTy tyOfTy =
doE
[ bindS
(tupP [varP (mkName "i0"), varP _tag])
[|deserialize $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
[|deserializeAt $(varE _initialOffset) $(varE _arr) $(varE _endOffset)|]
, noBindS
(caseE
(sigE (varE _tag) (conT tagType))
@ -241,7 +241,7 @@ mkDeserializeExpr False False headTy tyOfTy =
peekMatch (i, con) =
match
(litP (IntegerL i))
(normalB (mkDeserializeExprOne 'deserialize con)) []
(normalB (mkDeserializeExprOne 'deserializeAt con)) []
peekErr =
match
wildP
@ -279,11 +279,11 @@ mkDeserializeDec (SerializeConfig {..}) headTy cons = do
pure
( maybe
[]
(\x -> [PragmaD (InlineP 'deserialize x FunLike AllPhases)])
(\x -> [PragmaD (InlineP 'deserializeAt x FunLike AllPhases)])
cfgInlineDeserialize
++
[ FunD
'deserialize
'deserializeAt
[ Clause
(if isUnitType cons && not cfgConstructorTagAsString
then [VarP _initialOffset, WildP, WildP]
@ -300,7 +300,7 @@ mkDeserializeDec (SerializeConfig {..}) headTy cons = do
mkSerializeExprTag :: Name -> Int -> Q Exp
mkSerializeExprTag tagType tagVal =
[|serialize
[|serializeAt
$(varE _initialOffset)
$(varE _arr)
$((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
@ -335,7 +335,7 @@ mkSerializeExpr True False tyOfTy =
(doE [ bindS
(varP (mkName "i0"))
(serializeW8List _initialOffset _arr conEnc)
, noBindS (mkSerializeExprFields 'serialize fields)
, noBindS (mkSerializeExprFields 'serializeAt fields)
])
mkSerializeExpr False False tyOfTy =
@ -351,7 +351,7 @@ mkSerializeExpr False False tyOfTy =
[ matchConstructor
cname
(length fields)
(mkSerializeExprFields 'serialize fields)
(mkSerializeExprFields 'serializeAt fields)
])
-- Sum type
(MultiType cons) -> do
@ -368,7 +368,7 @@ mkSerializeExpr False False tyOfTy =
(mkSerializeExprTag tagType tagVal)
, noBindS
(mkSerializeExprFields
'serialize
'serializeAt
fields)
]))
(zip [0 ..] cons))
@ -388,11 +388,11 @@ mkSerializeDec (SerializeConfig {..}) headTy cons = do
pure
( maybe
[]
(\x -> [PragmaD (InlineP 'serialize x FunLike AllPhases)])
(\x -> [PragmaD (InlineP 'serializeAt x FunLike AllPhases)])
cfgInlineSerialize
++
[FunD
'serialize
'serializeAt
[ Clause
(if isUnitType cons && not cfgConstructorTagAsString
then [VarP _initialOffset, WildP, WildP]

34
core/src/Streamly/Internal/Data/Serialize/TH/Bottom.hs
View File

@ -13,9 +13,9 @@ module Streamly.Internal.Data.Serialize.TH.Bottom
-- ** Config
SerializeConfig(..)
, serializeConfig
, inlineSize
, inlineSerialize
, inlineDeserialize
, inlineAddSizeTo
, inlineSerializeAt
, inlineDeserializeAt
, encodeConstrNames
, encodeRecordFields
@ -84,7 +84,7 @@ import Streamly.Internal.Data.Unbox.TH (DataCon(..))
-- 'serializeConfig' and config setter functions to generate desired Config. For
-- example:
--
-- >>> (inlineSize (Just Inline)) . (inlineSerialize (Just Inlinable)) serializeConfig
-- >>> (inlineAddSizeTo (Just Inline)) . (inlineSerializeAt (Just Inlinable)) serializeConfig
--
data SerializeConfig =
SerializeConfig
@ -95,11 +95,11 @@ data SerializeConfig =
, cfgRecordSyntaxWithHeader :: Bool
}
-- | How should we inline the 'size' function? The default in 'serializeConfig'
-- is 'Nothing' which means left to the compiler. Forcing inline on @size@
-- | How should we inline the 'addSizeTo' function? The default in 'serializeConfig'
-- is 'Nothing' which means left to the compiler. Forcing inline on @addSizeTo@
-- function actually worsens some benchmarks and improves none.
inlineSize :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineSize v cfg = cfg {cfgInlineSize = v}
inlineAddSizeTo :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineAddSizeTo v cfg = cfg {cfgInlineSize = v}
-- XXX Should we make the default Inlinable instead?
@ -108,15 +108,15 @@ inlineSize v cfg = cfg {cfgInlineSize = v}
-- the code and increase in compilation times when there are big functions and
-- too many nesting levels so you can change it accordingly. A 'Nothing' value
-- leaves the decision to the compiler.
inlineSerialize :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineSerialize v cfg = cfg {cfgInlineSerialize = v}
inlineSerializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineSerializeAt v cfg = cfg {cfgInlineSerialize = v}
-- XXX Should we make the default Inlinable instead?
-- | How should we inline the 'deserialize' function? See guidelines in
-- 'inlineSerialize'.
inlineDeserialize :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineDeserialize v cfg = cfg {cfgInlineDeserialize = v}
-- 'inlineSerializeAt'.
inlineDeserializeAt :: Maybe Inline -> SerializeConfig -> SerializeConfig
inlineDeserializeAt v cfg = cfg {cfgInlineDeserialize = v}
-- | __Experimental__
--
@ -184,9 +184,9 @@ encodeRecordFields v cfg = cfg {cfgRecordSyntaxWithHeader = v}
-- | The default configuration settings are:
--
-- * 'inlineSize' 'Nothing'
-- * 'inlineSerialize' (Just Inline)
-- * 'inlineDeserialize' (Just Inline)
-- * 'inlineAddSizeTo' 'Nothing'
-- * 'inlineSerializeAt' (Just Inline)
-- * 'inlineDeserializeAt' (Just Inline)
--
serializeConfig :: SerializeConfig
serializeConfig =
@ -425,7 +425,7 @@ serializeW8List off arr w8List = do
makeBind i =
bindS
(varP (makeN (i + 1)))
[|$(varE 'serialize)
[|$(varE 'serializeAt)
$(varE (makeN i))
$(varE arr)
($(litIntegral (w8List !! i)) :: Word8)|]

46
core/src/Streamly/Internal/Data/Serialize/TH/RecHeader.hs
View File

@ -103,36 +103,36 @@ newtype CompactList a =
-- the list is 255.
instance forall a. Serialize a => Serialize (CompactList a) where
-- {-# INLINE size #-}
size acc (CompactList xs) =
foldl' size (acc + (Unbox.sizeOf (Proxy :: Proxy Word8))) xs
-- {-# INLINE addSizeTo #-}
addSizeTo acc (CompactList xs) =
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Word8))) xs
-- Inlining this causes large compilation times for tests
{-# INLINABLE deserialize #-}
deserialize off arr sz = do
(off1, len8) <- deserialize off arr sz :: IO (Int, Word8)
{-# INLINABLE deserializeAt #-}
deserializeAt off arr sz = do
(off1, len8) <- deserializeAt off arr sz :: IO (Int, Word8)
let len = w8_int len8
peekList f o i | i >= 3 = do
-- Unfold the loop three times
(o1, x1) <- deserialize o arr sz
(o2, x2) <- deserialize o1 arr sz
(o3, x3) <- deserialize o2 arr sz
(o1, x1) <- deserializeAt o arr sz
(o2, x2) <- deserializeAt o1 arr sz
(o3, x3) <- deserializeAt o2 arr sz
peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3)
peekList f o 0 = pure (o, f [])
peekList f o i = do
(o1, x) <- deserialize o arr sz
(o1, x) <- deserializeAt o arr sz
peekList (f . (x:)) o1 (i - 1)
(nextOff, lst) <- peekList id off1 len
pure (nextOff, CompactList lst)
-- Inlining this causes large compilation times for tests
{-# INLINABLE serialize #-}
serialize off arr (CompactList val) = do
void $ serialize off arr (int_w8 (length val) :: Word8)
{-# INLINABLE serializeAt #-}
serializeAt off arr (CompactList val) = do
void $ serializeAt off arr (int_w8 (length val) :: Word8)
let off1 = off + Unbox.sizeOf (Proxy :: Proxy Word8)
let pokeList o [] = pure o
pokeList o (x:xs) = do
o1 <- serialize o arr x
o1 <- serializeAt o arr x
pokeList o1 xs
pokeList off1 val
@ -154,7 +154,7 @@ isMaybeType _ = False
-- We add 4 here because we use 'serializeWithSize' for serializing.
exprGetSize :: Q Exp -> (Int, Type) -> Q Exp
exprGetSize acc (i, _) =
[|size $(acc) $(varE (mkFieldName i)) + 4|]
[|addSizeTo $(acc) $(varE (mkFieldName i)) + 4|]
sizeOfHeader :: SimpleDataCon -> Int
sizeOfHeader (SimpleDataCon _ fields) =
@ -227,7 +227,7 @@ headerValue (SimpleDataCon _ fields) =
{-# INLINE serializeWithSize #-}
serializeWithSize :: Serialize a => Int -> MutByteArray -> a -> IO Int
serializeWithSize off arr val = do
off1 <- serialize (off + 4) arr val
off1 <- serializeAt (off + 4) arr val
Unbox.pokeAt off arr (int_w32 (off1 - off - 4) :: Word32)
pure off1
@ -238,7 +238,7 @@ mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
-- We first compare the header length encoded and the current header
-- length. Only if the header lengths match, we compare the headers.
[|do $(varP afterHLen) <-
serialize
serializeAt
($(varE initialOffset) + 4)
$(varE _arr)
($(litIntegral hlen) :: Word32)
@ -264,7 +264,7 @@ mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
{-# INLINE deserializeWithSize #-}
deserializeWithSize ::
Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
deserializeWithSize off arr endOff = deserialize (off + 4) arr endOff
deserializeWithSize off arr endOff = deserializeAt (off + 4) arr endOff
conUpdateFuncDec :: Name -> [Field] -> Q [Dec]
conUpdateFuncDec funcName fields = do
@ -282,7 +282,7 @@ conUpdateFuncDec funcName fields = do
wildP
(normalB
[|do (valOff, valLen :: Word32) <-
deserialize
deserializeAt
$(varE curOff)
$(varE arr)
$(varE endOff)
@ -317,7 +317,7 @@ conUpdateFuncDec funcName fields = do
(litP fnameLit)
(normalB
[|do (valOff, valLen :: Word32) <-
deserialize
deserializeAt
$(varE currOff)
$(varE arr)
$(varE endOff)
@ -345,7 +345,7 @@ mkDeserializeKeysDec funcName updateFunc (SimpleDataCon cname fields) = do
errorUnsupported "The datatype should use record syntax."
method <-
[|do (dataOff, hlist :: CompactList (CompactList Word8)) <-
deserialize $(varE hOff) $(varE arr) $(varE endOff)
deserializeAt $(varE hOff) $(varE arr) $(varE endOff)
let keys = wListToString . unCompactList <$> unCompactList hlist
($(varP kvEncoded), _) <-
foldlM
@ -390,9 +390,9 @@ mkRecDeserializeExpr initialOff endOff deserializeWithKeys con = do
sizeForHeaderLength = 4 -- Word32
sizePreData = sizeForFinalOff + sizeForHeaderLength + hlen
[|do (hlenOff, encLen :: Word32) <-
deserialize $(varE initialOff) $(varE _arr) $(varE endOff)
deserializeAt $(varE initialOff) $(varE _arr) $(varE endOff)
($(varP hOff), hlen1 :: Word32) <-
deserialize hlenOff $(varE _arr) $(varE endOff)
deserializeAt hlenOff $(varE _arr) $(varE endOff)
if (hlen1 == $(litIntegral hlen)) && $(xorCmp hval hOff _arr)
then do
let $(varP (makeI 0)) =

115
core/src/Streamly/Internal/Data/Serialize/Type.hs
View File

@ -58,14 +58,14 @@ import GHC.Exts
-- particular constructor. For variable length data types the length is encoded
-- along with the data.
--
-- The 'deserialize' operation reads bytes from the mutable byte array and
-- The 'deserializeAt' operation reads bytes from the mutable byte array and
-- builds a Haskell data type from these bytes, the number of bytes it reads
-- depends on the type and the encoded value it is reading. 'serialize'
-- depends on the type and the encoded value it is reading. 'serializeAt'
-- operation converts a Haskell data type to its binary representation which
-- must consist of as many bytes as returned by the @size@ operation on that
-- must consist of as many bytes as added by the @addSizeTo@ operation for that
-- value and then stores these bytes into the mutable byte array. The
-- programmer is expected to use the @size@ operation and allocate an array of
-- sufficient length before calling 'serialize'.
-- programmer is expected to use the @addSizeTo@ operation and allocate an
-- array of sufficient length before calling 'serializeAt'.
--
-- IMPORTANT: The serialized data's byte ordering remains the same as the host
-- machine's byte order. Therefore, it can not be deserialized from host
@ -98,15 +98,15 @@ import GHC.Exts
--
-- >>> :{
-- instance Serialize Object where
-- size acc obj = size (size acc (_obj1 obj)) (_obj2 obj)
-- deserialize i arr len = do
-- addSizeTo acc obj = addSizeTo (addSizeTo acc (_obj1 obj)) (_obj2 obj)
-- deserializeAt i arr len = do
-- -- Check the array bounds before reading
-- (i1, x0) <- deserialize i arr len
-- (i2, x1) <- deserialize i1 arr len
-- (i1, x0) <- deserializeAt i arr len
-- (i2, x1) <- deserializeAt i1 arr len
-- pure (i2, Object x0 x1)
-- serialize i arr (Object x0 x1) = do
-- i1 <- serialize i arr x0
-- i2 <- serialize i1 arr x1
-- serializeAt i arr (Object x0 x1) = do
-- i1 <- serializeAt i arr x0
-- i2 <- serializeAt i1 arr x1
-- pure i2
-- :}
--
@ -117,30 +117,30 @@ class Serialize a where
-- It is of the form @Int -> a -> Int@ because you can have tail-recursive
-- traversal of the structures.
-- | @size accum value@ returns @accum@ incremented by the size of the
-- | @addSizeTo accum value@ returns @accum@ incremented by the size of the
-- serialized representation of @value@ in bytes. Size cannot be zero. It
-- should be at least 1 byte.
size :: Int -> a -> Int
addSizeTo :: Int -> a -> Int
-- We can implement the following functions without returning the `Int`
-- offset but that may require traversing the Haskell structure again to get
-- the size. Therefore, this is a performance optimization.
-- | @deserialize byte-offset array arrayLen@ deserializes a value from the
-- | @deserializeAt byte-offset array arrayLen@ deserializes a value from the
-- given byte-offset in the array. Returns a tuple consisting of the next
-- byte-offset and the deserialized value.
--
-- Throws an exception if the operation would exceed the supplied arrayLen.
deserialize :: Int -> MutByteArray -> Int -> IO (Int, a)
deserializeAt :: Int -> MutByteArray -> Int -> IO (Int, a)
-- | @serialize byte-offset array value@ writes the serialized
-- | @serializeAt byte-offset array value@ writes the serialized
-- representation of the @value@ in the array at the given byte-offset.
-- Returns the next byte-offset.
--
-- This is an unsafe operation, the programmer must ensure that the array
-- has enough space available to serialize the value as determined by the
-- @size@ operation.
serialize :: Int -> MutByteArray -> a -> IO Int
-- @addSizeTo@ operation.
serializeAt :: Int -> MutByteArray -> a -> IO Int
--------------------------------------------------------------------------------
-- Instances
@ -191,7 +191,7 @@ deserializeUnsafe off arr sz =
if (next <= sz)
then Unbox.peekAt off arr >>= \val -> pure (next, val)
else error
$ "deserialize: accessing array at offset = "
$ "deserializeAt: accessing array at offset = "
++ show (next - 1)
++ " max valid offset = " ++ show (sz - 1)
@ -201,19 +201,19 @@ serializeUnsafe off arr val =
let next = off + Unbox.sizeOf (Proxy :: Proxy a)
in do
#ifdef DEBUG
checkBounds "serialize" next arr
checkBounds "serializeAt" next arr
#endif
Unbox.pokeAt off arr val
pure next
#define DERIVE_SERIALIZE_FROM_UNBOX(_type) \
instance Serialize _type where \
; {-# INLINE size #-} \
; size acc _ = acc + Unbox.sizeOf (Proxy :: Proxy _type) \
; {-# INLINE deserialize #-} \
; deserialize off arr end = deserializeUnsafe off arr end :: IO (Int, _type) \
; {-# INLINE serialize #-} \
; serialize = \
; {-# INLINE addSizeTo #-} \
; addSizeTo acc _ = acc + Unbox.sizeOf (Proxy :: Proxy _type) \
; {-# INLINE deserializeAt #-} \
; deserializeAt off arr end = deserializeUnsafe off arr end :: IO (Int, _type) \
; {-# INLINE serializeAt #-} \
; serializeAt = \
serializeUnsafe :: Int -> MutByteArray -> _type -> IO Int
DERIVE_SERIALIZE_FROM_UNBOX(())
@ -237,68 +237,69 @@ DERIVE_SERIALIZE_FROM_UNBOX((FunPtr a))
instance forall a. Serialize a => Serialize [a] where
-- {-# INLINE size #-}
size acc xs = foldl' size (acc + (Unbox.sizeOf (Proxy :: Proxy Int))) xs
-- {-# INLINE addSizeTo #-}
addSizeTo acc xs =
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Int))) xs
-- Inlining this causes large compilation times for tests
{-# INLINABLE deserialize #-}
deserialize off arr sz = do
(off1, len64) <- deserialize off arr sz :: IO (Int, Int64)
{-# INLINABLE deserializeAt #-}
deserializeAt off arr sz = do
(off1, len64) <- deserializeAt off arr sz :: IO (Int, Int64)
let len = (fromIntegral :: Int64 -> Int) len64
peekList f o i | i >= 3 = do
-- Unfold the loop three times
(o1, x1) <- deserialize o arr sz
(o2, x2) <- deserialize o1 arr sz
(o3, x3) <- deserialize o2 arr sz
(o1, x1) <- deserializeAt o arr sz
(o2, x2) <- deserializeAt o1 arr sz
(o3, x3) <- deserializeAt o2 arr sz
peekList (f . (\xs -> x1:x2:x3:xs)) o3 (i - 3)
peekList f o 0 = pure (o, f [])
peekList f o i = do
(o1, x) <- deserialize o arr sz
(o1, x) <- deserializeAt o arr sz
peekList (f . (x:)) o1 (i - 1)
peekList id off1 len
-- Inlining this causes large compilation times for tests
{-# INLINABLE serialize #-}
serialize off arr val = do
{-# INLINABLE serializeAt #-}
serializeAt off arr val = do
let off1 = off + Unbox.sizeOf (Proxy :: Proxy Int64)
let pokeList acc o [] =
Unbox.pokeAt off arr (acc :: Int64) >> pure o
pokeList acc o (x:xs) = do
o1 <- serialize o arr x
o1 <- serializeAt o arr x
pokeList (acc + 1) o1 xs
pokeList 0 off1 val
instance Serialize (Array a) where
{-# INLINE size #-}
size i (Array {..}) = i + (arrEnd - arrStart) + 8
{-# INLINE addSizeTo #-}
addSizeTo i (Array {..}) = i + (arrEnd - arrStart) + 8
{-# INLINE deserialize #-}
deserialize off arr end = do
(off1, byteLen) <- deserialize off arr end :: IO (Int, Int)
{-# INLINE deserializeAt #-}
deserializeAt off arr end = do
(off1, byteLen) <- deserializeAt off arr end :: IO (Int, Int)
let off2 = off1 + byteLen
let slice = MutArray.MutArray arr off1 off2 off2
newArr <- MutArray.clone slice
pure (off2, Array.unsafeFreeze newArr)
{-# INLINE serialize #-}
serialize off arr (Array {..}) = do
{-# INLINE serializeAt #-}
serializeAt off arr (Array {..}) = do
let arrLen = arrEnd - arrStart
off1 <- serialize off arr arrLen
off1 <- serializeAt off arr arrLen
MBA.putSliceUnsafe arrContents arrStart arr off1 arrLen
pure (off1 + arrLen)
instance (Serialize a, Serialize b) => Serialize (a, b) where
{-# INLINE size #-}
size acc (a, b) = size (size acc a) b
{-# INLINE addSizeTo #-}
addSizeTo acc (a, b) = addSizeTo (addSizeTo acc a) b
{-# INLINE serialize #-}
serialize off arr (a, b) = do
off1 <- serialize off arr a
serialize off1 arr b
{-# INLINE serializeAt #-}
serializeAt off arr (a, b) = do
off1 <- serializeAt off arr a
serializeAt off1 arr b
{-# INLINE deserialize #-}
deserialize off arr end = do
(off1, a) <- deserialize off arr end
(off2, b) <- deserialize off1 arr end
{-# INLINE deserializeAt #-}
deserializeAt off arr end = do
(off1, a) <- deserializeAt off arr end
(off2, b) <- deserializeAt off1 arr end
pure (off2, (a, b))

8
test/Streamly/Test/Data/Serialize.hs
View File

@ -160,7 +160,7 @@ poke ::
=> a
-> IO (MutByteArray, Int, Int)
poke val = do
let sz = Serialize.size 0 val
let sz = Serialize.addSizeTo 0 val
let excessSize = 100
randomOff <- randomRIO (10, excessSize)
@ -171,7 +171,7 @@ poke val = do
serEndOff = randomOff + sz
arr <- Serialize.new arrSize
off1 <- Serialize.serialize serStartOff arr val
off1 <- Serialize.serializeAt serStartOff arr val
off1 `shouldBe` serEndOff
pure (arr, serStartOff, serEndOff)
@ -181,7 +181,7 @@ peekAndVerify ::
-> a
-> IO ()
peekAndVerify (arr, serStartOff, serEndOff) val = do
(off2, val2) <- Serialize.deserialize serStartOff arr serEndOff
(off2, val2) <- Serialize.deserializeAt serStartOff arr serEndOff
val2 `shouldBe` val
off2 `shouldBe` serEndOff
let slice = Array.Array arr serStartOff serEndOff
@ -207,7 +207,7 @@ testSerializeList
-> IO ()
testSerializeList sizeOfA val = do
let sz = Serialize.size 0 val
let sz = Serialize.addSizeTo 0 val
sz `shouldBe` sizeOfA

6
test/Streamly/Test/Data/Unbox.hs
View File

@ -40,8 +40,8 @@ import Test.Hspec as H
#define MODULE_NAME "Data.Serialize.Deriving.TH"
#define DERIVE_UNBOX(typ) $(deriveSerialize [d|instance Serialize typ|])
#define PEEK(i, arr, sz) (deserialize i arr sz)
#define POKE(i, arr, val) (serialize i arr val)
#define PEEK(i, arr, sz) (deserializeAt i arr sz)
#define POKE(i, arr, val) (serializeAt i arr val)
#define TYPE_CLASS Serialize
#else
@ -185,7 +185,7 @@ variableSizeOf ::
forall a. Serialize a
=> a
-> Int
variableSizeOf = size 0
variableSizeOf = addSizeTo 0
#endif
testSerialization ::