Am Sonntag, 17. Mai 2009 15:08:29 schrieb Don Stewart:
> Sven.Panne:
> > [...]
> > I think most problems can be fixed in a rather pragmatic way by adding a
> > few functions to the binary package:
> [...]
> Patches are welcome.
Attached. A few remarks:
* This is only a quick and mildly tested implementation of the IEEE
functions, especially NaNs, infinities and denormalized numbers are untested.
These problems could totally be avoided if we can coerce representations
directly, changing only their interpretation.
* The *host functions assume an IEEE platform, but this can easily be changed
(see comments).
* Perhaps one can use unsafeCoerce for word32ToFloat and friends, but I
haven't checked this.
* I've seen a few "{- INLINE -}" comments. Is this really wanted or only a
typo?
* A comment about using peek/poke for the *le/*be functions is wrong, because
this would introduce alignment constraints on some platforms.
I think the main point is to provide a nice and efficient API, hiding all the
dirty stuff in the implementation.
> > One final remarks: I think the low level functions of the binary package
> > should really keep the notions of "endianess" and "alignment constraints"
> > separate, something which isn't done currently: The *host functions have
> > alignment restrictions, the *be/*le functions don't. There is no good
> > reason for this non-orthogonality.
>
> That seems reasonable.
There are various ways to achieve this, but the most obvious way leads to a
combinatorial explosion of functions:
<no. of types> * 3 (LE/BE/host) * 2 (aligned/unaligned)
Furthermore, it would be good to split the binary package into the 2 layers
already discussed first, then it is perhaps a bit clearer what a nice API
would look like. I think it would be best to shift this API design discussion
to the libraries list.
Cheers,
S.
Only in binary-0.5.0.1: dist
diff -r -u binary-0.5.0.1.orig/src/Data/Binary/Builder.hs binary-0.5.0.1/src/Data/Binary/Builder.hs
--- binary-0.5.0.1.orig/src/Data/Binary/Builder.hs Sat Mar 7 23:59:44 2009
+++ binary-0.5.0.1/src/Data/Binary/Builder.hs Mon May 18 17:36:22 2009
@@ -41,20 +41,27 @@
, putWord16be -- :: Word16 -> Builder
, putWord32be -- :: Word32 -> Builder
, putWord64be -- :: Word64 -> Builder
+ , putFloatIEEEbe -- :: Float -> Builder
+ , putDoubleIEEEbe -- :: Double -> Builder
-- ** Little-endian writes
, putWord16le -- :: Word16 -> Builder
, putWord32le -- :: Word32 -> Builder
, putWord64le -- :: Word64 -> Builder
+ , putFloatIEEEle -- :: Float -> Builder
+ , putDoubleIEEEle -- :: Double -> Builder
-- ** Host-endian, unaligned writes
, putWordhost -- :: Word -> Builder
, putWord16host -- :: Word16 -> Builder
, putWord32host -- :: Word32 -> Builder
, putWord64host -- :: Word64 -> Builder
+ , putFloatIEEEhost -- :: Float -> Builder
+ , putDoubleIEEEhost -- :: Double -> Builder
) where
+import Prelude hiding (significand, exponent)
import Foreign
import Data.Monoid
import Data.Word
@@ -360,6 +367,60 @@
-- on a little endian machine:
-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)
+-- | Write a Float in IEEE big endian format
+putFloatIEEEbe :: Float -> Builder
+putFloatIEEEbe = putWord32be . floatToWord32
+{-# INLINE putFloatIEEEbe #-}
+
+-- | Write a Double in IEEE big endian format
+putDoubleIEEEbe :: Double -> Builder
+putDoubleIEEEbe = putWord64be . doubleToWord64
+{-# INLINE putDoubleIEEEbe #-}
+
+-- | Write a Float in IEEE little endian format
+putFloatIEEEle :: Float -> Builder
+putFloatIEEEle = putWord32le . floatToWord32
+{-# INLINE putFloatIEEEle #-}
+
+-- | Write a Double in IEEE little endian format
+putDoubleIEEEle :: Double -> Builder
+putDoubleIEEEle = putWord64le . doubleToWord64
+{-# INLINE putDoubleIEEEle #-}
+
+floatToWord32 :: Float -> Word32
+-- floatToWord32 = unsafeReinterpret
+floatToWord32 = encodeIEEE 8 23
+
+doubleToWord64 :: Double -> Word64
+-- doubleToWord64 = unsafeReinterpret
+doubleToWord64 = encodeIEEE 11 52
+
+-- TODO: Check if this works for denormalized numbers, NaNs and infinities.
+encodeIEEE :: (RealFloat a, Bits b, Integral b) => Int -> Int -> a -> b
+encodeIEEE exponentBits significandBits f =
+ (signBit `shiftL` (exponentBits + significandBits)) .|.
+ (exponentField `shiftL` significandBits) .|.
+ significandField
+ where (significand, exponent) = decodeFloat f
+
+ signBit | significand < 0 = 1
+ | otherwise = 0
+ exponentField | significand == 0 && exponent == 0 = 0
+ | otherwise = fromIntegral exponent + exponentBias + fromIntegral significandBits
+ significandField = fromIntegral (abs significand) .&. significandMask
+
+ exponentBias = bit (exponentBits - 1) - 1
+ significandMask = bit significandBits - 1
+
+{-
+-- Evil! Poor man's version of a C union. Can we use unsafeCoerce instead?
+unsafeReinterpret :: (Storable a, Storable b) => a -> b
+unsafeReinterpret w = unsafePerformIO $
+ alloca $ \p -> do
+ poke p w
+ peek (castPtr p)
+-}
+
------------------------------------------------------------------------
-- Unaligned, word size ops
@@ -391,6 +452,24 @@
putWord64host :: Word64 -> Builder
putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)
{-# INLINE putWord64host #-}
+
+-- | Write a Float in IEEE format, host order and host endianness.
+-- 4 bytes will be written, unaligned.
+putFloatIEEEhost :: Float -> Builder
+-- This assumes that our platform uses single precision IEEE floats for Float.
+-- Add ifdefs for platforms where this is not the case, e.g. falling back to
+-- the slow path via floatToWord32.
+putFloatIEEEhost f = writeNbytes (sizeOf (undefined :: Float)) (\p -> poke p f)
+{-# INLINE putFloatIEEEhost #-}
+
+-- | Write a Double in IEEE format, host order and host endianness.
+-- 8 bytes will be written, unaligned.
+putDoubleIEEEhost :: Double -> Builder
+-- This assumes that our platform uses double precision IEEE floats for Double.
+-- Add ifdefs for platforms where this is not the case, e.g. falling back to
+-- the slow path via doubleToWord64.
+putDoubleIEEEhost d = writeNbytes (sizeOf (undefined :: Double)) (\p -> poke p d)
+{-# INLINE putDoubleIEEEhost #-}
------------------------------------------------------------------------
-- Unchecked shifts
diff -r -u binary-0.5.0.1.orig/src/Data/Binary/Get.hs binary-0.5.0.1/src/Data/Binary/Get.hs
--- binary-0.5.0.1.orig/src/Data/Binary/Get.hs Sat Mar 7 23:59:44 2009
+++ binary-0.5.0.1/src/Data/Binary/Get.hs Mon May 18 17:36:07 2009
@@ -55,20 +55,27 @@
, getWord16be
, getWord32be
, getWord64be
+ , getFloatIEEEbe
+ , getDoubleIEEEbe
-- ** Little-endian reads
, getWord16le
, getWord32le
, getWord64le
+ , getFloatIEEEle
+ , getDoubleIEEEle
-- ** Host-endian, unaligned reads
, getWordhost
, getWord16host
, getWord32host
, getWord64host
+ , getFloatIEEEhost
+ , getDoubleIEEEhost
) where
+import Prelude hiding (significand, exponent)
import Control.Monad (when,liftM,ap)
import Control.Monad.Fix
import Data.Maybe (isNothing)
@@ -490,6 +497,59 @@
(fromIntegral (s `B.index` 0) )
{- INLINE getWord64le -}
+-- | Read an IEEE Float in big endian format
+getFloatIEEEbe :: Get Float
+getFloatIEEEbe = fmap word32ToFloat getWord32be
+{- INLINE getFloatIEEEbe -}
+
+-- | Read an IEEE Double in big endian format
+getDoubleIEEEbe :: Get Double
+getDoubleIEEEbe = fmap word64ToDouble getWord64be
+{- INLINE getDoubleIEEEbe -}
+
+-- | Read an IEEE Float in little endian format
+getFloatIEEEle :: Get Float
+getFloatIEEEle = fmap word32ToFloat getWord32le
+{- INLINE getFloatIEEEle -}
+
+-- | Read an IEEE Double in little endian format
+getDoubleIEEEle :: Get Double
+getDoubleIEEEle = fmap word64ToDouble getWord64le
+{- INLINE getDoubleIEEEle -}
+
+word32ToFloat :: Word32 -> Float
+-- word32ToFloat = unsafeReinterpret
+word32ToFloat = decodeIEEE 8 23
+
+word64ToDouble :: Word64 -> Double
+-- word64ToDouble = unsafeReinterpret
+word64ToDouble = decodeIEEE 11 52
+
+-- TODO: Check if this works for denormalized numbers, NaNs and infinities.
+decodeIEEE :: (Bits a, Integral a, RealFloat b) => Int -> Int -> a -> b
+decodeIEEE exponentBits significandBits n = encodeFloat significand exponent
+ where significand = adjustSign (fromIntegral (adjustSignificand significandField))
+ exponent = exponentField - exponentBias - significandBits
+
+ adjustSign = if n `testBit` (exponentBits + significandBits) then negate else id
+ adjustSignificand = if exponentField > 0 then (`setBit` significandBits) else id
+
+ exponentBias = bit (exponentBits - 1) - 1
+ exponentField = fromIntegral ((n `shiftR` significandBits) .&. exponentMask)
+ exponentMask = bit exponentBits - 1
+
+ significandField = n .&. significandMask
+ significandMask = bit significandBits - 1
+
+{-
+-- Evil! Poor man's version of a C union. Can we use unsafeCoerce instead?
+unsafeReinterpret :: (Storable a, Storable b) => a -> b
+unsafeReinterpret w = unsafePerformIO $
+ alloca $ \p -> do
+ poke p w
+ peek (castPtr p)
+-}
+
------------------------------------------------------------------------
-- Host-endian reads
@@ -514,6 +574,22 @@
getWord64host :: Get Word64
getWord64host = getPtr (sizeOf (undefined :: Word64))
{- INLINE getWord64host -}
+
+-- | /O(1)./ Read an IEEE Float in native host order and host endianess.
+getFloatIEEEhost :: Get Float
+-- This assumes that our platform uses single precision IEEE floats for Float.
+-- Add ifdefs for platforms where this is not the case, e.g. falling back to
+-- the slow path via word32ToFloat.
+getFloatIEEEhost = getPtr (sizeOf (undefined :: Float))
+{- INLINE getFloatIEEEhost -}
+
+-- | /O(1)./ Read an IEEE Double in native host order and host endianess.
+getDoubleIEEEhost :: Get Double
+-- This assumes that our platform uses double precision IEEE floats for Double.
+-- Add ifdefs for platforms where this is not the case, e.g. falling back to
+-- the slow path via word64ToDouble.
+getDoubleIEEEhost = getPtr (sizeOf (undefined :: Double))
+{- INLINE getDoubleIEEEhost -}
------------------------------------------------------------------------
-- Unchecked shifts
diff -r -u binary-0.5.0.1.orig/src/Data/Binary/Put.hs binary-0.5.0.1/src/Data/Binary/Put.hs
--- binary-0.5.0.1.orig/src/Data/Binary/Put.hs Sat Mar 7 23:59:44 2009
+++ binary-0.5.0.1/src/Data/Binary/Put.hs Mon May 18 17:40:36 2009
@@ -34,17 +34,23 @@
, putWord16be
, putWord32be
, putWord64be
+ , putFloatIEEEbe
+ , putDoubleIEEEbe
-- * Little-endian primitives
, putWord16le
, putWord32le
, putWord64le
+ , putFloatIEEEle
+ , putDoubleIEEEle
-- * Host-endian, unaligned writes
, putWordhost -- :: Word -> Put
, putWord16host -- :: Word16 -> Put
, putWord32host -- :: Word32 -> Put
, putWord64host -- :: Word64 -> Put
+ , putFloatIEEEhost -- :: Float -> Put
+ , putDoubleIEEEhost -- :: Double -> Put
) where
@@ -183,6 +189,26 @@
putWord64le = tell . B.putWord64le
{-# INLINE putWord64le #-}
+-- | Write a Float in IEEE big endian format
+putFloatIEEEbe :: Float -> Put
+putFloatIEEEbe = tell . B.putFloatIEEEbe
+{-# INLINE putFloatIEEEbe #-}
+
+-- | Write a Float in IEEE little endian format
+putFloatIEEEle :: Float -> Put
+putFloatIEEEle = tell . B.putFloatIEEEle
+{-# INLINE putFloatIEEEle #-}
+
+-- | Write a Double in IEEE big endian format
+putDoubleIEEEbe :: Double -> Put
+putDoubleIEEEbe = tell . B.putDoubleIEEEbe
+{-# INLINE putDoubleIEEEbe #-}
+
+-- | Write a Double in IEEE little endian format
+putDoubleIEEEle :: Double -> Put
+putDoubleIEEEle = tell . B.putDoubleIEEEle
+{-# INLINE putDoubleIEEEle #-}
+
------------------------------------------------------------------------
-- | /O(1)./ Write a single native machine word. The word is
@@ -213,3 +239,15 @@
putWord64host :: Word64 -> Put
putWord64host = tell . B.putWord64host
{-# INLINE putWord64host #-}
+
+-- | /O(1)./ Write a Float in IEEE format, native host order and endianess.
+-- For portability issues see @putwordh...@.
+putFloatIEEEhost :: Float -> Put
+putFloatIEEEhost = tell . B.putFloatIEEEhost
+{-# INLINE putFloatIEEEhost #-}
+
+-- | /O(1)./ Write a Double in IEEE format, native host order and endianess.
+-- For portability issues see @putwordh...@.
+putDoubleIEEEhost :: Double -> Put
+putDoubleIEEEhost = tell . B.putDoubleIEEEhost
+{-# INLINE putDoubleIEEEhost #-}
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
