diff --git a/Data/Storable/Endian.hs b/Data/Storable/Endian.hs new file mode 100644 --- /dev/null +++ b/Data/Storable/Endian.hs @@ -0,0 +1,289 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Storable.Endian +-- Copyright : (c) Eugene Kirpichov 2010 +-- License : New BSD +-- +-- Maintainer : Eugene Kirpichov +-- Stability : experimental +-- Portability : portable +-- +-- Storable instances with endianness, in the obvious way: for example, Int64LE +-- is peeked and poked in little-endian order. +-- + +module Data.Storable.Endian + ( + Int16LE(..), Int16BE(..), + Int32LE(..), Int32BE(..), + Int64LE(..), Int64BE(..), + Word16LE(..), Word16BE(..), + Word32LE(..), Word32BE(..), + Word64LE(..), Word64BE(..), + FloatLE(..), FloatBE(..), + DoubleLE(..), DoubleBE(..) + ) + where + +import Data.Storable.EndianTemplate + +import Foreign.Storable +import Foreign.Ptr +import System.IO.Unsafe +import Unsafe.Coerce + +import Data.Word +import Data.Bits +import Data.Char + +import Language.Haskell.TH + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word +import GHC.Int +#endif + +-- The code below has been adapted from the 'binary' library +-- http://hackage.haskell.org/package/binary + +------------------------------------------------------------------------ + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Ptr Word8 -> IO () +putWord16be w p = do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Ptr Word8 -> IO () +putWord16le w p = do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +{-# INLINE putWord16le #-} + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Ptr Word8 -> IO () +putWord32be w p = do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +{-# INLINE putWord32be #-} + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Ptr Word8 -> IO () +putWord32le w p = do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +{-# INLINE putWord32le #-} + +-- on a little endian machine: +-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Ptr Word8 -> IO () +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +putWord64be w p = do + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +putWord64be w p = do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Ptr Word8 -> IO () + +#if WORD_SIZE_IN_BITS < 64 +putWord64le w p = do + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +putWord64le w p = do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +{-# INLINE putWord64le #-} + +unsafePeekOff :: Ptr Word8 -> Int -> Word8 +unsafePeekOff p off = unsafePerformIO (p `peekElemOff` off) + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) +-- | Read a Word16 in big endian format +getWord16be :: Ptr Word8 -> IO Word16 +getWord16be p = do + return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w16` 8) .|. + (fromIntegral (p `unsafePeekOff` 1)) +{-# INLINE getWord16be #-} + +-- | Read a Word16 in little endian format +getWord16le :: Ptr Word8 -> IO Word16 +getWord16le p = do + return $! (fromIntegral (p `unsafePeekOff` 1) `shiftl_w16` 8) .|. + (fromIntegral (p `unsafePeekOff` 0) ) +{-# INLINE getWord16le #-} + +-- | Read a Word32 in big endian format +getWord32be :: Ptr Word8 -> IO Word32 +getWord32be p = do + return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w32` 24) .|. + (fromIntegral (p `unsafePeekOff` 1) `shiftl_w32` 16) .|. + (fromIntegral (p `unsafePeekOff` 2) `shiftl_w32` 8) .|. + (fromIntegral (p `unsafePeekOff` 3) ) +{-# INLINE getWord32be #-} + +-- | Read a Word32 in little endian format +getWord32le :: Ptr Word8 -> IO Word32 +getWord32le p = do + return $! (fromIntegral (p `unsafePeekOff` 3) `shiftl_w32` 24) .|. + (fromIntegral (p `unsafePeekOff` 2) `shiftl_w32` 16) .|. + (fromIntegral (p `unsafePeekOff` 1) `shiftl_w32` 8) .|. + (fromIntegral (p `unsafePeekOff` 0) ) +{-# INLINE getWord32le #-} + +-- | Read a Word64 in big endian format +getWord64be :: Ptr Word8 -> IO Word64 +getWord64be p = do + return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w64` 56) .|. + (fromIntegral (p `unsafePeekOff` 1) `shiftl_w64` 48) .|. + (fromIntegral (p `unsafePeekOff` 2) `shiftl_w64` 40) .|. + (fromIntegral (p `unsafePeekOff` 3) `shiftl_w64` 32) .|. + (fromIntegral (p `unsafePeekOff` 4) `shiftl_w64` 24) .|. + (fromIntegral (p `unsafePeekOff` 5) `shiftl_w64` 16) .|. + (fromIntegral (p `unsafePeekOff` 6) `shiftl_w64` 8) .|. + (fromIntegral (p `unsafePeekOff` 7) ) +{-# INLINE getWord64be #-} + +-- | Read a Word64 in little endian format +getWord64le :: Ptr Word8 -> IO Word64 +getWord64le p = do + return $! (fromIntegral (p `unsafePeekOff` 7) `shiftl_w64` 56) .|. + (fromIntegral (p `unsafePeekOff` 6) `shiftl_w64` 48) .|. + (fromIntegral (p `unsafePeekOff` 5) `shiftl_w64` 40) .|. + (fromIntegral (p `unsafePeekOff` 4) `shiftl_w64` 32) .|. + (fromIntegral (p `unsafePeekOff` 3) `shiftl_w64` 24) .|. + (fromIntegral (p `unsafePeekOff` 2) `shiftl_w64` 16) .|. + (fromIntegral (p `unsafePeekOff` 1) `shiftl_w64` 8) .|. + (fromIntegral (p `unsafePeekOff` 0) ) +{-# INLINE getWord64le #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif + +$(deriveEndian "Int16" 2 16) +$(deriveEndian "Int32" 4 32) +$(deriveEndian "Int64" 8 64) + +$(deriveEndian "Word16" 2 16) +$(deriveEndian "Word32" 4 32) +$(deriveEndian "Word64" 8 64) + +$(deriveEndian "Float" 4 32) +$(deriveEndian "Double" 8 64) + diff --git a/Data/Storable/EndianTemplate.hs b/Data/Storable/EndianTemplate.hs new file mode 100644 --- /dev/null +++ b/Data/Storable/EndianTemplate.hs @@ -0,0 +1,39 @@ +module Data.Storable.EndianTemplate where + +import Data.Char + +import Unsafe.Coerce +import Foreign.Ptr + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Control.Monad + +concatM :: (Monad m) => [m [a]] -> m [a] +concatM [] = return [] +concatM (m:ms) = liftM2 (++) m (concatM ms) + +deriveEndian :: String -> Int -> Int -> Q [Dec] +deriveEndian baseName bytes bits = concatM [mapM declareNewtype ["le", "be"], mapM deriveEndian' ["le", "be"]] + where + declareNewtype end = do + baseType <- conT (mkName baseName) + let typeName = baseName ++ map toUpper end + newtypeD (cxt []) (mkName typeName) [] (return $ NormalC (mkName typeName) [(NotStrict, baseType)]) [] + deriveEndian' end = do + let typeName = mkName $ baseName ++ map toUpper end + let getter = mkName $ "getWord" ++ show bits ++ end + let putter = mkName $ "putWord" ++ show bits ++ end + let vp = mkName "p" + let vx = mkName "x" + pokeBody <- [| $(varE putter) (unsafeCoerce $(varE vx)) (castPtr $(varE vp))|] + members <- concatM [ + [d| sizeOf _ = $(lift bytes) |] + ,[d| alignment _ = $(lift bytes) |] + ,[d| peek p = ($(conE typeName) . unsafeCoerce) `fmap` $(varE getter) (castPtr p) |] + ,return [FunD (mkName "poke") [Clause + [VarP (mkName "p"), ConP typeName [VarP (mkName "x")]] + (NormalB pokeBody) + []]] + ] + instanceD (cxt []) (appT (conT (mkName "Storable")) (conT typeName)) (map return members) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2010, Eugene Kirpichov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/storable-endian.cabal b/storable-endian.cabal new file mode 100644 --- /dev/null +++ b/storable-endian.cabal @@ -0,0 +1,29 @@ +Name: storable-endian +Version: 0.1.0 +License: BSD3 +License-file: LICENSE +Copyright: Eugene Kirpichov, 2010 +Author: Eugene Kirpichov +Maintainer: Eugene Kirpichov +Synopsis: Storable instances with endianness +Description: Storable instances with endianness +Category: Data +Cabal-Version: >= 1.6 +Build-Type: Simple +Source-repository head + type: git + location: git://github.com/jkff/storable-endian + +flag splitbase + description: Choose the new smaller, split-up base package. + +library + if flag(splitbase) + Build-Depends: base >= 3 && < 5 + else + Build-Depends: base < 3 + + Build-Depends: haskell98, template-haskell + Exposed-Modules: Data.Storable.Endian + Other-Modules: Data.Storable.EndianTemplate + Extensions: MagicHash, TemplateHaskell, CPP