diff --git a/gf.cabal b/gf.cabal index 54c0ad4e1..5ace12c34 100644 --- a/gf.cabal +++ b/gf.cabal @@ -89,7 +89,6 @@ Library hs-source-dirs: src/runtime/haskell if flag(custom-binary) - hs-source-dirs: src/binary other-modules: -- not really part of GF but I have changed the original binary library -- and we have to keep the copy for now. diff --git a/src/binary/Data/Binary.hs b/src/runtime/haskell/Data/Binary.hs similarity index 100% rename from src/binary/Data/Binary.hs rename to src/runtime/haskell/Data/Binary.hs diff --git a/src/binary/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs similarity index 100% rename from src/binary/Data/Binary/Builder.hs rename to src/runtime/haskell/Data/Binary/Builder.hs diff --git a/src/binary/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs similarity index 100% rename from src/binary/Data/Binary/Get.hs rename to src/runtime/haskell/Data/Binary/Get.hs diff --git a/src/binary/Data/Binary/IEEE754.lhs b/src/runtime/haskell/Data/Binary/IEEE754.lhs similarity index 68% rename from src/binary/Data/Binary/IEEE754.lhs rename to src/runtime/haskell/Data/Binary/IEEE754.lhs index 96cbefc5a..26395a054 100644 --- a/src/binary/Data/Binary/IEEE754.lhs +++ b/src/runtime/haskell/Data/Binary/IEEE754.lhs @@ -17,14 +17,14 @@ \begin{code} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Binary.IEEE754 ( - -- * Parsing - getFloat16be, getFloat16le - , getFloat32be, getFloat32le - , getFloat64be, getFloat64le - - -- * Serializing - , putFloat32be, putFloat32le - , putFloat64be, putFloat64le + -- * Parsing + getFloat16be, getFloat16le + , getFloat32be, getFloat32le + , getFloat64be, getFloat64le + + -- * Serializing + , putFloat32be, putFloat32le + , putFloat64be, putFloat64le ) where import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits) @@ -80,19 +80,19 @@ original float, and have not been unbiased or otherwise modified. \begin{code} splitBytes :: [Word8] -> RawFloat splitBytes bs = RawFloat width sign exp' sig expWidth sigWidth where - width = ByteCount (length bs) - nBits = bitsInWord8 bs - sign = if head bs .&. 0x80 == 0x80 - then Negative - else Positive - - expStart = 1 - expWidth = exponentWidth nBits - expEnd = expStart + expWidth - exp' = Exponent . fromIntegral $ bitSlice bs expStart expEnd - - sigWidth = nBits - expEnd - sig = Significand $ bitSlice bs expEnd nBits + width = ByteCount (length bs) + nBits = bitsInWord8 bs + sign = if head bs .&. 0x80 == 0x80 + then Negative + else Positive + + expStart = 1 + expWidth = exponentWidth nBits + expEnd = expStart + expWidth + exp' = Exponent . fromIntegral $ bitSlice bs expStart expEnd + + sigWidth = nBits - expEnd + sig = Significand $ bitSlice bs expEnd nBits \end{code} \subsubsection{Encodings and special values} @@ -123,14 +123,14 @@ are constructed using the {\tt Read} instances for {\tt Double} and \begin{code} merge :: (Read a, RealFloat a) => RawFloat -> a merge f@(RawFloat _ _ e sig eWidth _) - | e == 0 = if sig == 0 - then 0.0 - else denormalised f - | e == eMax - 1 = if sig == 0 - then read "Infinity" - else read "NaN" - | otherwise = normalised f - where eMax = 2 `pow` eWidth + | e == 0 = if sig == 0 + then 0.0 + else denormalised f + | e == eMax - 1 = if sig == 0 + then read "Infinity" + else read "NaN" + | otherwise = normalised f + where eMax = 2 `pow` eWidth \end{code} If a value is normalised, its significand has an implied {\tt 1} bit @@ -140,13 +140,13 @@ this value before being passed to {\tt encodeField}. \begin{code} normalised :: RealFloat a => RawFloat -> a normalised f = encodeFloat fraction exp' where - Significand sig = rawSignificand f - Exponent exp' = unbiased - sigWidth - - fraction = sig + (1 `bitShiftL` rawSignificandWidth f) - - sigWidth = fromIntegral $ rawSignificandWidth f - unbiased = unbias (rawExponent f) (rawExponentWidth f) + Significand sig = rawSignificand f + Exponent exp' = unbiased - sigWidth + + fraction = sig + (1 `bitShiftL` rawSignificandWidth f) + + sigWidth = fromIntegral $ rawSignificandWidth f + unbiased = unbias (rawExponent f) (rawExponentWidth f) \end{code} For denormalised values, the implied {\tt 1} bit is the least-significant @@ -155,11 +155,11 @@ bit of the exponent. \begin{code} denormalised :: RealFloat a => RawFloat -> a denormalised f = encodeFloat sig exp' where - Significand sig = rawSignificand f - Exponent exp' = unbiased - sigWidth + 1 - - sigWidth = fromIntegral $ rawSignificandWidth f - unbiased = unbias (rawExponent f) (rawExponentWidth f) + Significand sig = rawSignificand f + Exponent exp' = unbiased - sigWidth + 1 + + sigWidth = fromIntegral $ rawSignificandWidth f + unbiased = unbias (rawExponent f) (rawExponentWidth f) \end{code} By composing {\tt splitBytes} and {\tt merge}, the absolute value of the @@ -170,11 +170,11 @@ must be signed appropriately. getFloat :: (Read a, RealFloat a) => ByteCount -> ([Word8] -> RawFloat) -> Get a getFloat (ByteCount width) parser = do - raw <- fmap (parser . B.unpack) $ getByteString width - let absFloat = merge raw - return $ case rawSign raw of - Positive -> absFloat - Negative -> -absFloat + raw <- fmap (parser . B.unpack) $ getByteString width + let absFloat = merge raw + return $ case rawSign raw of + Positive -> absFloat + Negative -> -absFloat \end{code} \section{Serialising} @@ -211,24 +211,24 @@ stored in the {\tt RawFloat}. \begin{code} splitFloat :: RealFloat a => ByteCount -> a -> RawFloat splitFloat width x = raw where - raw = RawFloat width sign clampedExp clampedSig expWidth sigWidth - sign = if isNegativeNaN x || isNegativeZero x || x < 0 - then Negative - else Positive - clampedExp = clamp expWidth exp' - clampedSig = clamp sigWidth sig - (exp', sig) = case (dFraction, dExponent, biasedExp) of - (0, 0, _) -> (0, 0) - (_, _, 0) -> (0, Significand $ truncatedSig + 1) - _ -> (biasedExp, Significand truncatedSig) - expWidth = exponentWidth $ bitCount width - sigWidth = bitCount width - expWidth - 1 -- 1 for sign bit - - (dFraction, dExponent) = decodeFloat x - - rawExp = Exponent $ dExponent + fromIntegral sigWidth - biasedExp = bias rawExp expWidth - truncatedSig = abs dFraction - (1 `bitShiftL` sigWidth) + raw = RawFloat width sign clampedExp clampedSig expWidth sigWidth + sign = if isNegativeNaN x || isNegativeZero x || x < 0 + then Negative + else Positive + clampedExp = clamp expWidth exp' + clampedSig = clamp sigWidth sig + (exp', sig) = case (dFraction, dExponent, biasedExp) of + (0, 0, _) -> (0, 0) + (_, _, 0) -> (0, Significand $ truncatedSig + 1) + _ -> (biasedExp, Significand truncatedSig) + expWidth = exponentWidth $ bitCount width + sigWidth = bitCount width - expWidth - 1 -- 1 for sign bit + + (dFraction, dExponent) = decodeFloat x + + rawExp = Exponent $ dExponent + fromIntegral sigWidth + biasedExp = bias rawExp expWidth + truncatedSig = abs dFraction - (1 `bitShiftL` sigWidth) \end{code} Then, the {\tt RawFloat} is converted to a list of bytes by mashing all @@ -238,14 +238,14 @@ in 8-bit blocks. \begin{code} rawToBytes :: RawFloat -> [Word8] rawToBytes raw = integerToBytes mashed width where - RawFloat width sign exp' sig expWidth sigWidth = raw - sign' :: Word8 - sign' = case sign of - Positive -> 0 - Negative -> 1 - mashed = mashBits sig sigWidth . - mashBits exp' expWidth . - mashBits sign' 1 $ 0 + RawFloat width sign exp' sig expWidth sigWidth = raw + sign' :: Word8 + sign' = case sign of + Positive -> 0 + Negative -> 1 + mashed = mashBits sig sigWidth . + mashBits exp' expWidth . + mashBits sign' 1 $ 0 \end{code} {\tt clamp}, given a maximum bit count and a value, will strip any 1-bits @@ -254,9 +254,9 @@ in positions above the count. \begin{code} clamp :: (Num a, Bits a) => BitCount -> a -> a clamp = (.&.) . mask where - mask 1 = 1 - mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1 - mask _ = undefined + mask 1 = 1 + mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1 + mask _ = undefined \end{code} For merging the fields, just shift the starting integer over a bit and @@ -276,8 +276,8 @@ Each increment is converted to a byte and added to the final list. integerToBytes :: Integer -> ByteCount -> [Word8] integerToBytes _ 0 = [] integerToBytes x n = bytes where - bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step] - step = fromIntegral x .&. 0xFF + bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step] + step = fromIntegral x .&. 0xFF \end{code} Finally, the raw parsing is wrapped up in {\tt Put}. The second parameter @@ -287,7 +287,7 @@ serialisation. \begin{code} putFloat :: (RealFloat a) => ByteCount -> ([Word8] -> [Word8]) -> a -> Put putFloat width f x = putByteString $ B.pack bytes where - bytes = f . rawToBytes . splitFloat width $ x + bytes = f . rawToBytes . splitFloat width $ x \end{code} \section{Raw float components} @@ -299,14 +299,14 @@ shouldn't have it's implied MSB (if applicable). \begin{code} data RawFloat = RawFloat - { rawWidth :: ByteCount - , rawSign :: Sign - , rawExponent :: Exponent - , rawSignificand :: Significand - , rawExponentWidth :: BitCount - , rawSignificandWidth :: BitCount - } - deriving (Show) + { rawWidth :: ByteCount + , rawSign :: Sign + , rawExponent :: Exponent + , rawSignificand :: Significand + , rawExponentWidth :: BitCount + , rawSignificandWidth :: BitCount + } + deriving (Show) \end{code} \section{Exponents} @@ -317,10 +317,10 @@ size of the full structure. \begin{code} exponentWidth :: BitCount -> BitCount exponentWidth k - | k == 16 = 5 - | k == 32 = 8 - | k `mod` 32 == 0 = ceiling (4 * logBase 2 (fromIntegral k)) - 13 - | otherwise = error "Invalid length of floating-point value" + | k == 16 = 5 + | k == 32 = 8 + | k `mod` 32 == 0 = ceiling (4 * logBase 2 (fromIntegral k)) - 13 + | otherwise = error "Invalid length of floating-point value" \end{code} \begin{code} @@ -337,19 +337,19 @@ unbias e eWidth = e + 1 - (2 `pow` (eWidth - 1)) \begin{code} data Sign = Positive | Negative - deriving (Show) + deriving (Show) newtype Exponent = Exponent Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) + deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) newtype Significand = Significand Integer - deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) + deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) newtype BitCount = BitCount Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral) + deriving (Show, Eq, Num, Ord, Real, Enum, Integral) newtype ByteCount = ByteCount Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral) + deriving (Show, Eq, Num, Ord, Real, Enum, Integral) bitCount :: ByteCount -> BitCount bitCount (ByteCount x) = BitCount (x * 8) @@ -373,8 +373,8 @@ integer. \begin{code} bitSlice :: [Word8] -> BitCount -> BitCount -> Integer bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' where - step acc w = shiftL acc 8 + fromIntegral w - bitCount' = bitsInWord8 bs + step acc w = shiftL acc 8 + fromIntegral w + bitCount' = bitsInWord8 bs \end{code} Slice a single integer by start and end bit location @@ -382,9 +382,9 @@ Slice a single integer by start and end bit location \begin{code} sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer sliceInt x xBitCount s e = fromIntegral sliced where - sliced = (x .&. startMask) `bitShiftR` (xBitCount - e) - startMask = n1Bits (xBitCount - s) - n1Bits n = (2 `pow` n) - 1 + sliced = (x .&. startMask) `bitShiftR` (xBitCount - e) + startMask = n1Bits (xBitCount - s) + n1Bits n = (2 `pow` n) - 1 \end{code} Integral version of {\tt (**)} diff --git a/src/binary/Data/Binary/Put.hs b/src/runtime/haskell/Data/Binary/Put.hs similarity index 100% rename from src/binary/Data/Binary/Put.hs rename to src/runtime/haskell/Data/Binary/Put.hs