Commit 1e79ecf2 authored by Steffen Michels's avatar Steffen Michels

Merge branch '75-optimise-GenBinary-for-CONS-and-EITHER' into 'master'

Resolve "Follow-up from "add Data.Encoding.GenBinary""

Closes #75

See merge request !296
parents f4d9a748 9c2c55d9
Pipeline #33170 passed with stage
in 1 minute and 55 seconds
......@@ -47,8 +47,12 @@ definition module Data.Encoding.GenBinary
*/
from StdGeneric import :: UNIT (..), :: PAIR (..), :: EITHER (..), :: CONS (..), :: OBJECT (..), :: RECORD (..),
:: FIELD (..)
:: FIELD (..),
:: GenericConsDescriptor{gcd_index,gcd_type_def},
:: GenericTypeDefDescriptor{gtd_conses,gtd_num_conses},
:: ConsPos(..), getConsPath
from StdInt import class + (+), instance + Int
from StdList import !!
from Data.Maybe import :: Maybe (..), instance Functor Maybe
from Data.Func import $
from Data.Functor import class Functor (fmap)
......@@ -76,14 +80,14 @@ decode :: !{#Char} -> Maybe a | gBinaryDecode{|*|} a
class GenBinary a | gBinaryEncode{|*|}, gBinaryEncodingSize{|*|}, gBinaryDecode{|*|} a
:: *EncodingSt
:: *EncodingSt = {es_pos :: !Int, es_bits :: !*{#Char}, es_cons_path :: ![ConsPos]}
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x $ encodeBool False st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x $ encodeBool True st
gBinaryEncode{|CONS|} c (CONS x) st = c x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x st
gBinaryEncode{|CONS of d|} c (CONS x) st = c x $ encodeIntUsingNBits (ceil_log2 0 d.gcd_type_def.gtd_num_conses) d.gcd_index st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
......@@ -91,12 +95,15 @@ gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
derive gBinaryEncode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
(,,,,,,,)
// Only exported for gBinaryEncode{|CONS|}
encodeIntUsingNBits :: !Int !Int !*EncodingSt -> *EncodingSt
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x $ s + 1
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x $ s + 1
gBinaryEncodingSize{|CONS|} c (CONS x) s = c x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x s
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x s
gBinaryEncodingSize{|CONS of d|} c (CONS x) s = c x $ ceil_log2 s d.gcd_type_def.gtd_num_conses
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
......@@ -112,15 +119,16 @@ gBinaryDecode{|PAIR|} fx fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st
# (mbIsRight, st) = decodeBool st
= case mbIsRight of
Just isRight | isRight = appFst (fmap RIGHT) $ fr st
| otherwise = appFst (fmap LEFT) $ fl st
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st = case st.es_cons_path of
[] = (Nothing, st)
[ConsLeft:path] = appFst (fmap LEFT) $ fl {st & es_cons_path=path}
[ConsRight:path] = appFst (fmap RIGHT) $ fr {st & es_cons_path=path}
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT|} f st = appFst (fmap \x -> OBJECT x) $ f st
gBinaryDecode{|OBJECT of {gtd_conses,gtd_num_conses}|} f st =
case decodeIntWithNBits (ceil_log2 0 gtd_num_conses) st of
(Nothing, st) = (Nothing, st)
(Just i, st) = appFst (fmap \x -> OBJECT x) $ f {st & es_cons_path=getConsPath (gtd_conses!!i)}
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
derive gBinaryDecode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,),
......@@ -129,3 +137,5 @@ derive gBinaryDecode Int, Real, Bool, Char, String, [], {}, {!}, (), (,), (,,),
// This is only exported because it is used in exposed generic definitions.
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
decodeIntWithNBits :: !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
ceil_log2 :: !Int !Int -> Int
......@@ -12,10 +12,10 @@ encode x
#! encoded_size = gBinaryEncodingSize{|*|} x 0
#! arr_size = (encoded_size+7) >> 3
#! bits = createArray arr_size '\0'
= (gBinaryEncode{|*|} x (mkEncodingSt bits)).cs_bits
= (gBinaryEncode{|*|} x (mkEncodingSt bits)).es_bits
mkEncodingSt :: !*{#Char} -> *EncodingSt
mkEncodingSt arr = { cs_pos = 0, cs_bits = arr}
mkEncodingSt arr = {es_pos = 0, es_bits = arr, es_cons_path=[]}
generic gBinaryEncode a :: !a !*EncodingSt -> *EncodingSt
gBinaryEncode{|Int|} x st = encodeInt x st
......@@ -25,9 +25,9 @@ gBinaryEncode{|Bool|} x st = encodeBool x st
gBinaryEncode{|String|} xs st = encodeArray encodeChar xs st
gBinaryEncode{|UNIT|} _ st = st
gBinaryEncode{|PAIR|} cx cy (PAIR x y) st = cy y $ cx x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x $ encodeBool False st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x $ encodeBool True st
gBinaryEncode{|CONS|} c (CONS x) st = c x st
gBinaryEncode{|EITHER|} cl cr (LEFT x) st = cl x st
gBinaryEncode{|EITHER|} cl cr (RIGHT x) st = cr x st
gBinaryEncode{|CONS of d|} c (CONS x) st = c x $ encodeIntUsingNBits (ceil_log2 0 d.gcd_type_def.gtd_num_conses) d.gcd_index st
gBinaryEncode{|FIELD|} c (FIELD x) st = c x st
gBinaryEncode{|OBJECT|} c (OBJECT x) st = c x st
gBinaryEncode{|RECORD|} c (RECORD x) st = c x st
......@@ -42,13 +42,13 @@ encodeChar :: !Char !*EncodingSt -> *EncodingSt
encodeChar c st = encodeIntUsingNBytes 1 (toInt c) st
encodeBool :: !Bool !*EncodingSt -> *EncodingSt
encodeBool False st = {st & cs_pos = st.cs_pos + 1}
encodeBool True {cs_pos = pos, cs_bits = bits}
encodeBool False st = {st & es_pos = st.es_pos + 1}
encodeBool True cs=:{es_pos = pos, es_bits = bits}
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
= {cs_pos = inc pos, cs_bits = {bits & [byte_pos] = toChar $ int bitor bit_mask}}
= {cs & es_pos = inc pos, es_bits = {bits & [byte_pos] = toChar $ int bitor bit_mask}}
encodeReal :: !Real !*EncodingSt -> *EncodingSt
encodeReal real st = IF_INT_64_OR_32
......@@ -71,14 +71,20 @@ where
encode :: !Int !*EncodingSt -> *EncodingSt
encode 0 st = st
encode remainingBytes st
#! byte_pos = st.cs_pos >> 3
#! byte_pos = st.es_pos >> 3
#! st =
{ st
& cs_bits = {st.cs_bits & [byte_pos] = toChar $ int >> ((numBytes - remainingBytes) * 8)}
, cs_pos = st.cs_pos + 8
& es_bits = {st.es_bits & [byte_pos] = toChar $ int >> ((numBytes - remainingBytes) * 8)}
, es_pos = st.es_pos + 8
}
= encode (dec remainingBytes) st
encodeIntUsingNBits :: !Int !Int !*EncodingSt -> *EncodingSt
encodeIntUsingNBits 0 _ st = st
encodeIntUsingNBits numBits int st
# st = encodeBool (int bitand 1 == 1) st
= encodeIntUsingNBits (numBits - 1) (int >> 1) st
generic gBinaryEncodingSize a :: !a !Int -> Int
gBinaryEncodingSize{|Int|} _ s = (IF_INT_64_OR_32 64 32) + byteAlignedPosition s
gBinaryEncodingSize{|Real|} _ s = 64 + byteAlignedPosition s
......@@ -87,9 +93,9 @@ gBinaryEncodingSize{|Bool|} _ s = 1 + s
gBinaryEncodingSize{|String|} xs s = IF_INT_64_OR_32 64 32 + size xs * 8 + byteAlignedPosition s
gBinaryEncodingSize{|UNIT|} _ s = s
gBinaryEncodingSize{|PAIR|} cx cy (PAIR x y) s = cy y $ cx x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x $ s + 1
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x $ s + 1
gBinaryEncodingSize{|CONS|} c (CONS x) s = c x s
gBinaryEncodingSize{|EITHER|} cl _ (LEFT x) s = cl x s
gBinaryEncodingSize{|EITHER|} _ cr (RIGHT x) s = cr x s
gBinaryEncodingSize{|CONS of d|} c (CONS x) s = c x $ ceil_log2 s d.gcd_type_def.gtd_num_conses
gBinaryEncodingSize{|FIELD|} c (FIELD x) s = c x s
gBinaryEncodingSize{|OBJECT|} c (OBJECT x) s = c x s
gBinaryEncodingSize{|RECORD|} c (RECORD x) s = c x s
......@@ -110,16 +116,16 @@ gBinaryDecode{|PAIR|} fx fy st
= case (mbX, mbY) of
(Just x, Just y) = (Just $ PAIR x y, st)
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st
# (mbIsRight, st) = decodeBool st
= case mbIsRight of
Just isRight
| isRight = appFst (fmap RIGHT) $ fr st
| otherwise = appFst (fmap LEFT) $ fl st
_ = (Nothing, st)
gBinaryDecode{|EITHER|} fl fr st = case st.es_cons_path of
[] = (Nothing, st)
[ConsLeft:path] = appFst (fmap LEFT) $ fl {st & es_cons_path=path}
[ConsRight:path] = appFst (fmap RIGHT) $ fr {st & es_cons_path=path}
gBinaryDecode{|CONS|} f st = appFst (fmap CONS) $ f st
gBinaryDecode{|FIELD|} f st = appFst (fmap \x -> FIELD x) $ f st
gBinaryDecode{|OBJECT|} f st = appFst (fmap \x -> OBJECT x) $ f st
gBinaryDecode{|OBJECT of {gtd_conses,gtd_num_conses}|} f st =
case decodeIntWithNBits (ceil_log2 0 gtd_num_conses) st of
(Nothing, st) = (Nothing, st)
(Just i, st) = appFst (fmap \x -> OBJECT x) $ f {st & es_cons_path=getConsPath (gtd_conses!!i)}
gBinaryDecode{|RECORD|} f st = appFst (fmap RECORD) $ f st
gBinaryDecode{|[]|} f st = decodeList f st
gBinaryDecode{|{}|} f st = decodeArray f st
......@@ -134,7 +140,7 @@ decodeChar st
= (toChar <$> mbInt, st)
decodeBool :: !*EncodingSt -> (!Maybe Bool, !*EncodingSt)
decodeBool cs=:{cs_pos = pos, cs_bits = bits}
decodeBool cs=:{es_pos = pos, es_bits = bits}
#! s = size bits
#! byte_pos = pos >> 3
#! bit_pos = pos bitand 7
......@@ -142,7 +148,7 @@ decodeBool cs=:{cs_pos = pos, cs_bits = bits}
#! int = toInt bits.[byte_pos]
#! bit_mask = 1 << bit_pos
#! bit = (bit_mask bitand int) <> 0
= (Just bit, {cs & cs_pos = inc pos})
= (Just bit, {cs & es_pos = inc pos})
decodeReal :: !*EncodingSt -> (!Maybe Real, !*EncodingSt)
decodeReal st = IF_INT_64_OR_32 decodeReal64 decodeReal32 $ st
......@@ -182,24 +188,39 @@ where
arrToList xs = [x \\ x <-: xs]
decodeIntWithNBytes :: !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decodeIntWithNBytes numBytes st=:{cs_pos} = decode numBytes 0 $ withByteAlignedPosition st
decodeIntWithNBytes numBytes st=:{es_pos} = decode numBytes 0 $ withByteAlignedPosition st
where
// we can decode an entire byte at once, as the start position is byte-aligned
decode :: !Int !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decode 0 int st = (Just int, st)
decode remainingBytes int st=:{cs_bits}
#! byte_pos = st.cs_pos >> 3
| byte_pos == size cs_bits = (Nothing, st)
#! byte = toInt cs_bits.[byte_pos]
= decode (dec remainingBytes) (byte << ((numBytes - remainingBytes) * 8) + int) {st & cs_pos = st.cs_pos + 8}
decode remainingBytes int st=:{es_bits}
#! byte_pos = st.es_pos >> 3
| byte_pos == size es_bits = (Nothing, st)
#! byte = toInt es_bits.[byte_pos]
= decode (dec remainingBytes) (byte << ((numBytes - remainingBytes) * 8) + int) {st & es_pos = st.es_pos + 8}
decodeIntWithNBits :: !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decodeIntWithNBits numBits st = decode numBits 0 st
where
decode :: !Int !Int !*EncodingSt -> (!Maybe Int, !*EncodingSt)
decode 0 int st = (Just int, st)
decode remainingBits int st
# (mbBool,st) = decodeBool st
| isNothing mbBool
= (Nothing, st)
= decode (remainingBits - 1) (int + (if (fromJust mbBool) 1 0 << (numBits - remainingBits))) st
withByteAlignedPosition :: !*EncodingSt -> *EncodingSt
withByteAlignedPosition st=:{cs_pos} = {st & cs_pos = byteAlignedPosition cs_pos}
withByteAlignedPosition st=:{es_pos} = {st & es_pos = byteAlignedPosition es_pos}
byteAlignedPosition :: !Int -> Int
byteAlignedPosition pos = (pos + 7) bitand -8
:: *EncodingSt = {cs_pos :: !Int, cs_bits :: !*{#Char}}
ceil_log2 :: !Int !Int -> Int
ceil_log2 acc n
| n < 2
= acc
= ceil_log2 (acc + 1) (n / 2 + n rem 2)
derive gBinaryEncode (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
derive gBinaryEncodingSize (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment