packages feed

cereal (empty) → 0.1

raw patch · 13 files changed

+3371/−0 lines, 13 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin, Galois, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ cereal.cabal view
@@ -0,0 +1,48 @@+name:                   cereal+version:                0.1+license:                BSD3+license-file:           LICENSE+author:                 Lennart Kolmodin <kolmodin@dtek.chalmers.se>, Galois Inc.+maintainer:             Trevor Elliott <trevor@galois.com>+category:               Data, Parsing+stability:              provisional+build-type:             Simple+cabal-version:          >= 1.6+synopsis:               A binary serialization library+extra-source-files:     tests/Benchmark.hs,+                        tests/CBenchmark.c,+                        tests/CBenchmark.h,+                        tests/Makefile,+                        tests/MemBench.hs,+                        tests/Tests.hs+description:+  A binary serialization library, similar to binary, that introduces an isolate+  primitive for parser isolation, and replaces the asynchronous errors with a+  user-handleable Either type.  Similar to binary in performance, but uses a+  strict ByteString instead of a lazy ByteString, thus restricting it to+  operating on finite inputs.++flag split-base+        default: True++library+        build-depends:          bytestring+        if flag(split-base)+                build-depends:  base == 4.*, containers, array+        else+                build-depends:  base < 3.0++        hs-source-dirs: src++        exposed-modules:Data.Serialize,+                        Data.Serialize.Put,+                        Data.Serialize.Get,+                        Data.Serialize.Builder++        extensions:     CPP,+                        FlexibleContexts,+                        FlexibleInstances,+                        Rank2Types,+                        MagicHash++        ghc-options:    -O2 -Wall -fliberate-case-threshold=1000
+ src/Data/Serialize.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts  #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Serialize+-- Copyright   : Lennart Kolmodin, Galois Inc. 2009+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   :+-- Portability :+--+-----------------------------------------------------------------------------++module Data.Serialize (++    -- * The Serialize class+      Serialize(..)++    -- $example++    -- * The Get and Put monads+    , Get+    , Put+    , Putter++    -- * Useful helpers for writing instances+    , putWord8+    , getWord8++    -- * Serialize serialisation+    , encode+    , decode++    , module Data.Word -- useful++    ) where++import Data.Serialize.Put+import Data.Serialize.Get++import Control.Monad+import Data.Array.Unboxed+import Data.ByteString (ByteString)+import Data.Char    (chr,ord)+import Data.List    (unfoldr)+import Data.Word+import Foreign++-- And needed for the instances:+import qualified Data.ByteString      as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Map             as Map+import qualified Data.Set             as Set+import qualified Data.IntMap          as IntMap+import qualified Data.IntSet          as IntSet+import qualified Data.Ratio           as R+import qualified Data.Tree            as T+import qualified Data.Sequence        as Seq++------------------------------------------------------------------------++class Serialize t where+    -- | Encode a value in the Put monad.+    put :: Putter t+    -- | Decode a value in the Get monad+    get :: Get t++------------------------------------------------------------------------+-- Wrappers to run the underlying monad++-- | Encode a value using binary serialisation to a lazy ByteString.+--+encode :: Serialize a => a -> ByteString+encode = runPut . put++-- | Decode a value from a lazy ByteString, reconstructing the original structure.+--+decode :: Serialize a => ByteString -> Either String a+decode = runGet get++------------------------------------------------------------------------+-- Simple instances++-- The () type need never be written to disk: values of singleton type+-- can be reconstructed from the type alone+instance Serialize () where+    put ()  = return ()+    get     = return ()++-- Bools are encoded as a byte in the range 0 .. 1+instance Serialize Bool where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2+instance Serialize Ordering where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++------------------------------------------------------------------------+-- Words and Ints++-- Words8s are written as bytes+instance Serialize Word8 where+    put     = putWord8+    get     = getWord8++-- Words16s are written as 2 bytes in big-endian (network) order+instance Serialize Word16 where+    put     = putWord16be+    get     = getWord16be++-- Words32s are written as 4 bytes in big-endian (network) order+instance Serialize Word32 where+    put     = putWord32be+    get     = getWord32be++-- Words64s are written as 8 bytes in big-endian (network) order+instance Serialize Word64 where+    put     = putWord64be+    get     = getWord64be++-- Int8s are written as a single byte.+instance Serialize Int8 where+    put i   = put (fromIntegral i :: Word8)+    get     = liftM fromIntegral (get :: Get Word8)++-- Int16s are written as a 2 bytes in big endian format+instance Serialize Int16 where+    put i   = put (fromIntegral i :: Word16)+    get     = liftM fromIntegral (get :: Get Word16)++-- Int32s are written as a 4 bytes in big endian format+instance Serialize Int32 where+    put i   = put (fromIntegral i :: Word32)+    get     = liftM fromIntegral (get :: Get Word32)++-- Int64s are written as a 8 bytes in big endian format+instance Serialize Int64 where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++------------------------------------------------------------------------++-- Words are are written as Word64s, that is, 8 bytes in big endian format+instance Serialize Word where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++-- Ints are are written as Int64s, that is, 8 bytes in big endian format+instance Serialize Int where+    put i   = put (fromIntegral i :: Int64)+    get     = liftM fromIntegral (get :: Get Int64)++------------------------------------------------------------------------+-- +-- Portable, and pretty efficient, serialisation of Integer+--++-- Fixed-size type for a subset of Integer+type SmallInt = Int32++-- Integers are encoded in two ways: if they fit inside a SmallInt,+-- they're written as a byte tag, and that value.  If the Integer value+-- is too large to fit in a SmallInt, it is written as a byte array,+-- along with a sign and length field.++instance Serialize Integer where++    put n | n >= lo && n <= hi = do+        putWord8 0+        put (fromIntegral n :: SmallInt)  -- fast path+     where+        lo = fromIntegral (minBound :: SmallInt) :: Integer+        hi = fromIntegral (maxBound :: SmallInt) :: Integer++    put n = do+        putWord8 1+        put sign+        put (unroll (abs n))         -- unroll the bytes+     where+        sign = fromIntegral (signum n) :: Word8++    get = do+        tag <- get :: Get Word8+        case tag of+            0 -> liftM fromIntegral (get :: Get SmallInt)+            _ -> do sign  <- get+                    bytes <- get+                    let v = roll bytes+                    return $! if sign == (1 :: Word8) then v else - v++--+-- Fold and unfold an Integer to and from a list of its bytes+--+unroll :: Integer -> [Word8]+unroll = unfoldr step+  where+    step 0 = Nothing+    step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll   = foldr unstep 0+  where+    unstep b a = a `shiftL` 8 .|. fromIntegral b++instance (Serialize a,Integral a) => Serialize (R.Ratio a) where+    put r = put (R.numerator r) >> put (R.denominator r)+    get = liftM2 (R.%) get get++------------------------------------------------------------------------++-- Char is serialised as UTF-8+instance Serialize Char where+    put a | c <= 0x7f     = put (fromIntegral c :: Word8)+          | c <= 0x7ff    = do put (0xc0 .|. y)+                               put (0x80 .|. z)+          | c <= 0xffff   = do put (0xe0 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | c <= 0x10ffff = do put (0xf0 .|. w)+                               put (0x80 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | otherwise     = error "Not a valid Unicode code point"+     where+        c = ord a+        z, y, x, w :: Word8+        z = fromIntegral (c           .&. 0x3f)+        y = fromIntegral (shiftR c 6  .&. 0x3f)+        x = fromIntegral (shiftR c 12 .&. 0x3f)+        w = fromIntegral (shiftR c 18 .&. 0x7)++    get = do+        let getByte = liftM (fromIntegral :: Word8 -> Int) get+            shiftL6 = flip shiftL 6 :: Int -> Int+        w <- getByte+        r <- case () of+                _ | w < 0x80  -> return w+                  | w < 0xe0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    return (x .|. shiftL6 (xor 0xc0 w))+                  | w < 0xf0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    y <- liftM (xor 0x80) getByte+                                    return (y .|. shiftL6 (x .|. shiftL6+                                            (xor 0xe0 w)))+                  | otherwise -> do+                                x <- liftM (xor 0x80) getByte+                                y <- liftM (xor 0x80) getByte+                                z <- liftM (xor 0x80) getByte+                                return (z .|. shiftL6 (y .|. shiftL6+                                        (x .|. shiftL6 (xor 0xf0 w))))+        return $! chr r++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (Serialize a, Serialize b) => Serialize (a,b) where+    put = putTwoOf put put+    get = getTwoOf get get++instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where+    put (a,b,c)         = put a >> put b >> put c+    get                 = liftM3 (,,) get get get++instance (Serialize a, Serialize b, Serialize c, Serialize d)+        => Serialize (a,b,c,d) where+    put (a,b,c,d)       = put a >> put b >> put c >> put d+    get                 = liftM4 (,,,) get get get get++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e)+        => Serialize (a,b,c,d,e) where+    put (a,b,c,d,e)     = put a >> put b >> put c >> put d >> put e+    get                 = liftM5 (,,,,) get get get get get++-- +-- and now just recurse:+--++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e+         , Serialize f)+        => Serialize (a,b,c,d,e,f) where+    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))+    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e+         , Serialize f, Serialize g)+        => Serialize (a,b,c,d,e,f,g) where+    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,+          Serialize f, Serialize g, Serialize h)+        => Serialize (a,b,c,d,e,f,g,h) where+    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+    get                   = do (a,(b,c,d,e,f,g,h)) <- get+                               return (a,b,c,d,e,f,g,h)++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,+          Serialize f, Serialize g, Serialize h, Serialize i)+        => Serialize (a,b,c,d,e,f,g,h,i) where+    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get+                                 return (a,b,c,d,e,f,g,h,i)++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,+          Serialize f, Serialize g, Serialize h, Serialize i, Serialize j)+        => Serialize (a,b,c,d,e,f,g,h,i,j) where+    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get+                                   return (a,b,c,d,e,f,g,h,i,j)++------------------------------------------------------------------------+-- Container types++instance Serialize a => Serialize [a] where+    put = putListOf put+    get = getListOf get++instance (Serialize a) => Serialize (Maybe a) where+    put = putMaybeOf put+    get = getMaybeOf get++instance (Serialize a, Serialize b) => Serialize (Either a b) where+    put = putEitherOf put put+    get = getEitherOf get get++------------------------------------------------------------------------+-- ByteStrings (have specially efficient instances)++instance Serialize B.ByteString where+    put bs = do put (B.length bs)+                putByteString bs+    get    = get >>= getByteString++instance Serialize L.ByteString where+    put bs = do put (fromIntegral (L.length bs) :: Int)+                putLazyByteString bs+    get    = get >>= getLazyByteString+++------------------------------------------------------------------------+-- Maps and Sets++instance (Ord a, Serialize a) => Serialize (Set.Set a) where+    put = putSetOf put+    get = getSetOf get++instance (Ord k, Serialize k, Serialize e) => Serialize (Map.Map k e) where+    put = putMapOf put put+    get = getMapOf get get++instance Serialize IntSet.IntSet where+    put = putIntSetOf put+    get = getIntSetOf get++instance (Serialize e) => Serialize (IntMap.IntMap e) where+    put = putIntMapOf put put+    get = getIntMapOf get get++------------------------------------------------------------------------+-- Queues and Sequences++instance (Serialize e) => Serialize (Seq.Seq e) where+    put = putSeqOf put+    get = getSeqOf get++------------------------------------------------------------------------+-- Floating point++instance Serialize Double where+    put d = put (decodeFloat d)+    get   = liftM2 encodeFloat get get++instance Serialize Float where+    put f = put (decodeFloat f)+    get   = liftM2 encodeFloat get get++------------------------------------------------------------------------+-- Trees++instance (Serialize e) => Serialize (T.Tree e) where+    put = putTreeOf put+    get = getTreeOf get++------------------------------------------------------------------------+-- Arrays++instance (Serialize i, Ix i, Serialize e) => Serialize (Array i e) where+    put = putIArrayOf put put+    get = getIArrayOf get get++--+-- The IArray UArray e constraint is non portable. Requires flexible instances+--+instance (Serialize i, Ix i, Serialize e, IArray UArray e)+  => Serialize (UArray i e) where+    put = putIArrayOf put put+    get = getIArrayOf get get
+ src/Data/Serialize/Builder.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE CPP       #-}+{-# LANGUAGE MagicHash #-}+-- for unboxed shifts++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Serialize.Builder+-- Copyright   : Lennart Kolmodin, Ross Paterson, Galois Inc. 2009+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   :+-- Portability :+--+-- Efficient construction of lazy bytestrings.+--+-----------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Data.Serialize.Builder (++    -- * The Builder type+      Builder+    , toByteString+    , toLazyByteString++    -- * Constructing Builders+    , empty+    , singleton+    , append+    , fromByteString        -- :: S.ByteString -> Builder+    , fromLazyByteString    -- :: L.ByteString -> Builder++    -- * Flushing the buffer state+    , flush++    -- * Derived Builders+    -- ** Big-endian writes+    , putWord16be           -- :: Word16 -> Builder+    , putWord32be           -- :: Word32 -> Builder+    , putWord64be           -- :: Word64 -> Builder++    -- ** Little-endian writes+    , putWord16le           -- :: Word16 -> Builder+    , putWord32le           -- :: Word32 -> Builder+    , putWord64le           -- :: Word64 -> Builder++    -- ** Host-endian, unaligned writes+    , putWordhost           -- :: Word -> Builder+    , putWord16host         -- :: Word16 -> Builder+    , putWord32host         -- :: Word32 -> Builder+    , putWord64host         -- :: Word64 -> Builder++  ) where++import Data.Monoid+import Foreign+import qualified Data.ByteString               as S+import qualified Data.ByteString.Lazy          as L+import qualified Data.ByteString.Internal      as S+import qualified Data.ByteString.Lazy.Internal as L++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word (Word32(..),Word16(..),Word64(..))++#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608+import GHC.Word (uncheckedShiftRL64#)+#endif+#else+import Data.Word+#endif++------------------------------------------------------------------------++-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's.+-- There are several functions for constructing 'Builder's, but only one+-- to inspect them: to extract any data, you have to turn them into lazy+-- 'L.ByteString's using 'toLazyByteString'.+--+-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte+-- arrays piece by piece.  As each buffer is filled, it is \'popped\'+-- off, to become a new chunk of the resulting lazy 'L.ByteString'.+-- All this is hidden from the user of the 'Builder'.++newtype Builder = Builder {+        -- Invariant (from Data.ByteString.Lazy):+        --      The lists include no null ByteStrings.+        runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]+    }++instance Monoid Builder where+    mempty  = empty+    {-# INLINE mempty #-}+    mappend = append+    {-# INLINE mappend #-}++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+--  * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = Builder id+{-# INLINE empty #-}++-- | /O(1)./ A Builder taking a single byte, satisfying+--+--  * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@+--+singleton :: Word8 -> Builder+singleton = writeN 1 . flip poke+{-# INLINE singleton #-}++------------------------------------------------------------------------++-- | /O(1)./ The concatenation of two Builders, an associative operation+-- with identity 'empty', satisfying+--+--  * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@+--+append :: Builder -> Builder -> Builder+append (Builder f) (Builder g) = Builder (f . g)+{-# INLINE append #-}++-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying+--+--  * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@+--+fromByteString :: S.ByteString -> Builder+fromByteString bs+  | S.null bs = empty+  | otherwise = flush `append` mapBuilder (bs :)+{-# INLINE fromByteString #-}++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+--  * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++)+{-# INLINE fromLazyByteString #-}++------------------------------------------------------------------------++-- Our internal buffer type+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)+                     {-# UNPACK #-} !Int                -- offset+                     {-# UNPACK #-} !Int                -- used bytes+                     {-# UNPACK #-} !Int                -- length left++------------------------------------------------------------------------++toByteString :: Builder -> S.ByteString+toByteString m = S.concat $ unsafePerformIO $ do+  buf <- newBuffer defaultSize+  return (runBuilder (m `append` flush) (const []) buf)++-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.+-- The construction work takes place if and when the relevant part of+-- the lazy 'L.ByteString' is demanded.+--+toLazyByteString :: Builder -> L.ByteString+toLazyByteString m = L.fromChunks $ unsafePerformIO $ do+    buf <- newBuffer defaultSize+    return (runBuilder (m `append` flush) (const []) buf)++-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,+-- yielding a new chunk in the result lazy 'L.ByteString'.+flush :: Builder+flush = Builder $ \ k buf@(Buffer p o u l) ->+    if u == 0+      then k buf+      else S.PS p o u : k (Buffer p (o+u) 0 l)++------------------------------------------------------------------------++--+-- copied from Data.ByteString.Lazy+--+defaultSize :: Int+defaultSize = 32 * k - overhead+    where k = 1024+          overhead = 2 * sizeOf (undefined :: Int)++------------------------------------------------------------------------++-- | Sequence an IO operation on the buffer+unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder+unsafeLiftIO f =  Builder $ \ k buf -> S.inlinePerformIO $ do+    buf' <- f buf+    return (k buf')+{-# INLINE unsafeLiftIO #-}++-- | Get the size of the buffer+withSize :: (Int -> Builder) -> Builder+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->+    runBuilder (f l) k buf++-- | Map the resulting list of bytestrings.+mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder+mapBuilder f = Builder (f .)++------------------------------------------------------------------------++-- | Ensure that there are at least @n@ many bytes available.+ensureFree :: Int -> Builder+ensureFree n = n `seq` withSize $ \ l ->+    if n <= l then empty else+        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))+{-# INLINE ensureFree #-}++-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- bytes into the memory.+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder+writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)+{-# INLINE writeN #-}++writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer+writeNBuffer n f (Buffer fp o u l) = do+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+    return (Buffer fp o (u+n) (l-n))+{-# INLINE writeNBuffer #-}++newBuffer :: Int -> IO Buffer+newBuffer size = do+    fp <- S.mallocByteString size+    return $! Buffer fp 0 0 size+{-# INLINE newBuffer #-}++------------------------------------------------------------------------+-- Aligned, host order writes of storable values++-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- storable values into the memory.+writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder+writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f)+{-# INLINE writeNbytes #-}++writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer+writeNBufferBytes n f (Buffer fp o u l) = do+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+    return (Buffer fp o (u+n) (l-n))+{-# INLINE writeNBufferBytes #-}++------------------------------------------------------------------------++--+-- 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 -> Builder+putWord16be w = writeN 2 $ \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 -> Builder+putWord16le w = writeN 2 $ \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 -> Builder+putWord32be w = writeN 4 $ \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 #-}++--+-- a data type to tag Put/Check. writes construct these which are then+-- inlined and flattened. matching Checks will be more robust with rules.+--++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Builder+putWord32le w = writeN 4 $ \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 -> Builder+#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 =+    let a = fromIntegral (shiftr_w64 w 32) :: Word32+        b = fromIntegral w                 :: Word32+    in writeN 8 $ \p -> do+    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 = writeN 8 $ \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 -> Builder++#if WORD_SIZE_IN_BITS < 64+putWord64le w =+    let b = fromIntegral (shiftr_w64 w 32) :: Word32+        a = fromIntegral w                 :: Word32+    in writeN 8 $ \p -> do+    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 = writeN 8 $ \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 #-}++-- on a little endian machine:+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)++------------------------------------------------------------------------+-- Unaligned, word size ops++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost :: Word -> Builder+putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w)+{-# INLINE putWordhost #-}++-- | Write a Word16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putWord16host :: Word16 -> Builder+putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16)+{-# INLINE putWord16host #-}++-- | Write a Word32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putWord32host :: Word32 -> Builder+putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32)+{-# INLINE putWord32host #-}++-- | Write a Word64 in native host order.+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- 8 bytes will be written, unaligned.+putWord64host :: Word64 -> Builder+putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)+{-# INLINE putWord64host #-}++------------------------------------------------------------------------+-- 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
+ src/Data/Serialize/Get.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE CPP        #-}+{-# LANGUAGE MagicHash  #-}+{-# LANGUAGE Rank2Types #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Serialize.Get+-- Copyright   : Lennart Kolmodin, Galois Inc. 2009+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   :+-- Portability :+--+-- The Get monad. A monad for efficiently building structures from+-- strict ByteStrings+--+-----------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Data.Serialize.Get (++    -- * The Get type+      Get+    , runGet+    , runGetState++    -- * Parsing+    , isolate+    , skip+    , uncheckedSkip+    , lookAhead+    , lookAheadM+    , lookAheadE+    , uncheckedLookAhead++    -- * Utility+    , getBytes+    , remaining+    , isEmpty++    -- * Parsing particular types+    , getWord8++    -- ** ByteStrings+    , getByteString+    , getRemaining+    , getLazyByteString++    -- ** Big-endian reads+    , getWord16be+    , getWord32be+    , getWord64be++    -- ** Little-endian reads+    , getWord16le+    , getWord32le+    , getWord64le++    -- ** Host-endian, unaligned reads+    , getWordhost+    , getWord16host+    , getWord32host+    , getWord64host++    -- ** Containers+    , getTwoOf+    , getListOf+    , getIArrayOf+    , getTreeOf+    , getSeqOf+    , getMapOf+    , getIntMapOf+    , getSetOf+    , getIntSetOf+    , getMaybeOf+    , getEitherOf++  ) where++import Control.Applicative (Applicative(..),Alternative(..))+import Control.Monad (unless,when,ap,MonadPlus(..),liftM2)+import Data.Array.IArray (IArray,listArray)+import Data.Ix (Ix)+import Data.List (intercalate)+import Data.Maybe (isNothing)+import Foreign++import qualified Data.ByteString          as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy     as L+import qualified Data.IntMap              as IntMap+import qualified Data.IntSet              as IntSet+import qualified Data.Map                 as Map+import qualified Data.Sequence            as Seq+import qualified Data.Set                 as Set+import qualified Data.Tree                as T+++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word+#endif++type Trace = [String] -> String++type Failure   r = String            -> Either String (r, B.ByteString)+type Success a r = B.ByteString -> a -> Either String (r, B.ByteString)++-- | The Get monad is an Exception and State monad.+newtype Get a = Get+  { unGet :: forall r. Trace -> B.ByteString+                    -> Failure   r -- failure+                    -> Success a r -- success+                    -> Either String (r, B.ByteString) }++instance Functor Get where+    fmap p m = Get (\t s0 f k -> unGet m t s0 f (\s a -> k s (p a)))++instance Applicative Get where+    pure  = return+    (<*>) = ap++instance Alternative Get where+    empty = failDesc "empty"+    (<|>) = mplus++-- Definition directly from Control.Monad.State.Strict+instance Monad Get where+    return a = Get (\_ s0 _ k -> k s0 a)+    m >>= g  = Get (\t s0 f k -> unGet m t s0 f (\s a -> unGet (g a) t s f k))+    fail     = failDesc++instance MonadPlus Get where+    mzero = failDesc "mzero"+    mplus a b = Get (\t s0 f k -> unGet a t s0 (\_ -> unGet b t s0 f k) k)++------------------------------------------------------------------------++formatTrace :: Trace+formatTrace [] = "Empty call stack"+formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n"++get :: Get B.ByteString+get  = Get (\_ s0 _ k -> k s0 s0)++put :: B.ByteString -> Get ()+put s = Get (\_ _ _ k -> k s ())++label :: String -> Get a -> Get a+label l m = Get (\t s0 k -> unGet m (\ls -> t (l:ls)) s0 k)++finalK :: Success a a+finalK s a = Right (a,s)++failK :: Failure a+failK  = Left++-- | Run the Get monad applies a 'get'-based parser on the input ByteString+runGet :: Get a -> B.ByteString -> Either String a+runGet m str = case unGet m formatTrace str failK finalK of+  Left  i      -> Left i+  Right (a, _) -> Right a++-- | Run the Get monad applies a 'get'-based parser on the input+-- ByteString. Additional to the result of get it returns the number of+-- consumed bytes and the rest of the input.+runGetState :: Get a -> B.ByteString -> Int+            -> Either String (a, B.ByteString)+runGetState m str off =+    case unGet m formatTrace (B.drop off str) failK finalK of+      Left i        -> Left i+      Right (a, bs) -> Right (a, bs)++------------------------------------------------------------------------++-- | Isolate an action to operating within a fixed block of bytes.  The action+--   is required to consume all the bytes that it is isolated to.+isolate :: String -> Int -> Get a -> Get a+isolate l n m = label l $ do+  s <- get+  let left = B.length s+  unless (n <= left) (fail "not enough space left to isolate")+  let (s',rest) = B.splitAt n s+  put s'+  a    <- m+  used <- get+  unless (B.null used) (fail "not all bytes parsed in isolate")+  put rest+  return a++failDesc :: String -> Get a+failDesc err = do+    let msg = "Failed reading" ++ err+    Get (\t _ f _ -> f (msg ++ "\n" ++ t []))++-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.+skip :: Int -> Get ()+skip n = do+  s <- get+  when (B.length s < n) (fail "too few bytes")+  put (B.drop n s)++-- | Skip ahead @n@ bytes. No error if there isn't enough bytes.+uncheckedSkip :: Int -> Get ()+uncheckedSkip n = do+    s <- get+    put (B.drop n s)++-- | Run @ga@, but return without consuming its input.+-- Fails if @ga@ fails.+lookAhead :: Get a -> Get a+lookAhead ga = do+    s <- get+    a <- ga+    put s+    return a++-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.+-- Fails if @gma@ fails.+lookAheadM :: Get (Maybe a) -> Get (Maybe a)+lookAheadM gma = do+    s <- get+    ma <- gma+    when (isNothing ma) (put s)+    return ma++-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.+-- Fails if @gea@ fails.+lookAheadE :: Get (Either a b) -> Get (Either a b)+lookAheadE gea = do+    s <- get+    ea <- gea+    case ea of+        Left _ -> put s+        _      -> return ()+    return ea++-- | Get the next up to @n@ bytes as a ByteString, without consuming them.+uncheckedLookAhead :: Int -> Get B.ByteString+uncheckedLookAhead n = do+    s <- get+    return (B.take n s)++------------------------------------------------------------------------+-- Utility++-- | Get the number of remaining unparsed bytes.+-- Useful for checking whether all input has been consumed.+-- Note that this forces the rest of the input.+remaining :: Get Int+remaining = B.length `fmap` get++-- | Test whether all input has been consumed,+-- i.e. there are no remaining unparsed bytes.+isEmpty :: Get Bool+isEmpty = B.null `fmap` get++------------------------------------------------------------------------+-- Utility with ByteStrings++-- | An efficient 'get' method for strict ByteStrings. Fails if fewer+-- than @n@ bytes are left in the input.+getByteString :: Int -> Get B.ByteString+getByteString  = getBytes++getRemaining :: Get B.ByteString+getRemaining  = getBytes =<< remaining++getLazyByteString :: Int64 -> Get L.ByteString+getLazyByteString n = f `fmap` getBytes (fromIntegral n)+  where f bs = L.fromChunks [bs]+++------------------------------------------------------------------------+-- Helpers++-- | Pull @n@ bytes from the input, as a strict ByteString.+getBytes :: Int -> Get B.ByteString+getBytes n = do+    s <- get+    when (n > B.length s) (fail "too few bytes")+    let (consume,rest) = B.splitAt n s+    put rest+    return consume++------------------------------------------------------------------------+-- Primtives++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts...++getPtr :: Storable a => Int -> Get a+getPtr n = do+    (fp,o,_) <- B.toForeignPtr `fmap` getBytes n+    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)++------------------------------------------------------------------------++-- | Read a Word8 from the monad state+getWord8 :: Get Word8+getWord8 = getPtr (sizeOf (undefined :: Word8))++-- | Read a Word16 in big endian format+getWord16be :: Get Word16+getWord16be = do+    s <- getBytes 2+    return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.index` 1))++-- | Read a Word16 in little endian format+getWord16le :: Get Word16+getWord16le = do+    s <- getBytes 2+    return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.index` 0) )++-- | Read a Word32 in big endian format+getWord32be :: Get Word32+getWord32be = do+    s <- getBytes 4+    return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.index` 3) )++-- | Read a Word32 in little endian format+getWord32le :: Get Word32+getWord32le = do+    s <- getBytes 4+    return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.index` 0) )++-- | Read a Word64 in big endian format+getWord64be :: Get Word64+getWord64be = do+    s <- getBytes 8+    return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.index` 7) )++-- | Read a Word64 in little endian format+getWord64le :: Get Word64+getWord64le = do+    s <- getBytes 8+    return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.index` 0) )++------------------------------------------------------------------------+-- Host-endian reads++-- | /O(1)./ Read a single native machine word. The word is read in+-- host order, host endian form, for the machine you're on. On a 64 bit+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.+getWordhost :: Get Word+getWordhost = getPtr (sizeOf (undefined :: Word))++-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.+getWord16host :: Get Word16+getWord16host = getPtr (sizeOf (undefined :: Word16))++-- | /O(1)./ Read a Word32 in native host order and host endianness.+getWord32host :: Get Word32+getWord32host = getPtr  (sizeOf (undefined :: Word32))++-- | /O(1)./ Read a Word64 in native host order and host endianess.+getWord64host   :: Get Word64+getWord64host = getPtr  (sizeOf (undefined :: Word64))++------------------------------------------------------------------------+-- 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+++-- Containers ------------------------------------------------------------------++getTwoOf :: Get a -> Get b -> Get (a,b)+getTwoOf ma mb = liftM2 (,) ma mb++-- | Get a list in the following format:+--   Word64 (big endian format)+--   element 1+--   ...+--   element n+getListOf :: Get a -> Get [a]+getListOf m = go [] =<< getWord64be+  where+  go as 0 = return (reverse as)+  go as i = do x <- m+               x `seq` go (x:as) (i - 1)++-- | Get an IArray in the following format:+--   index (lower bound)+--   index (upper bound)+--   Word64 (big endian format)+--   element 1+--   ...+--   element n+getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e)+getIArrayOf ix e = liftM2 listArray (getTwoOf ix ix) (getListOf e)++-- | Get a sequence in the following format:+--   Word64 (big endian format)+--   element 1+--   ...+--   element n+getSeqOf :: Get a -> Get (Seq.Seq a)+getSeqOf m = go Seq.empty =<< getWord64be+  where+  go xs 0 = return $! xs+  go xs n = xs `seq` n `seq` do+              x <- m+              go (xs Seq.|> x) (n - 1)++-- | Read as a list of lists.+getTreeOf :: Get a -> Get (T.Tree a)+getTreeOf m = liftM2 T.Node m (getListOf (getTreeOf m))++-- | Read as a list of pairs of key and element.+getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a)+getMapOf k m = Map.fromDistinctAscList `fmap` getListOf (getTwoOf k m)++-- | Read as a list of pairs of int and element.+getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a)+getIntMapOf i m = IntMap.fromDistinctAscList `fmap` getListOf (getTwoOf i m)++-- | Read as a list of elements.+getSetOf :: Ord a => Get a -> Get (Set.Set a)+getSetOf m = Set.fromDistinctAscList `fmap` getListOf m++-- | Read as a list of ints.+getIntSetOf :: Get Int -> Get IntSet.IntSet+getIntSetOf m = IntSet.fromDistinctAscList `fmap` getListOf m++-- | Read in a Maybe in the following format:+--   Word8 (0 for Nothing, anything else for Just)+--   element (when Just)+getMaybeOf :: Get a -> Get (Maybe a)+getMaybeOf m = do+  tag <- getWord8+  case tag of+    0 -> return Nothing+    _ -> Just `fmap` m++-- | Read an Either, in the following format:+--   Word8 (0 for Left, anything else for Right)+--   element a when 0, element b otherwise+getEitherOf :: Get a -> Get b -> Get (Either a b)+getEitherOf ma mb = do+  tag <- getWord8+  case tag of+    0 -> Left  `fmap` ma+    _ -> Right `fmap` mb
+ src/Data/Serialize/Put.hs view
@@ -0,0 +1,298 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Serialize.Put+-- Copyright   : Lennart Kolmodin, Galois Inc. 2009+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   :+-- Portability :+--+-- The Put monad. A monad for efficiently constructing lazy bytestrings.+--+-----------------------------------------------------------------------------++module Data.Serialize.Put (++    -- * The Put type+      Put+    , PutM(..)+    , Putter+    , runPut+    , runPutM+    , putBuilder+    , execPut++    -- * Flushing the implicit parse state+    , flush++    -- * Primitives+    , putWord8+    , putByteString+    , putLazyByteString++    -- * Big-endian primitives+    , putWord16be+    , putWord32be+    , putWord64be++    -- * Little-endian primitives+    , putWord16le+    , putWord32le+    , putWord64le++    -- * Host-endian, unaligned writes+    , putWordhost+    , putWord16host+    , putWord32host+    , putWord64host++    -- * Containers+    , putTwoOf+    , putListOf+    , putIArrayOf+    , putSeqOf+    , putTreeOf+    , putMapOf+    , putIntMapOf+    , putSetOf+    , putIntSetOf+    , putMaybeOf+    , putEitherOf++  ) where++import Data.Serialize.Builder (Builder, toByteString)+import qualified Data.Serialize.Builder as B++import Control.Applicative+import Data.Array.Unboxed+import Data.Ix+import Data.Monoid+import Data.Word+import qualified Data.ByteString        as S+import qualified Data.ByteString.Lazy   as L+import qualified Data.IntMap            as IntMap+import qualified Data.IntSet            as IntSet+import qualified Data.Map               as Map+import qualified Data.Sequence          as Seq+import qualified Data.Set               as Set+import qualified Data.Tree              as T+++------------------------------------------------------------------------++-- XXX Strict in buffer only. +data PairS a = PairS a {-# UNPACK #-}!Builder++sndS :: PairS a -> Builder+sndS (PairS _ b) = b++-- | The PutM type. A Writer monad over the efficient Builder monoid.+newtype PutM a = Put { unPut :: PairS a }++-- | Put merely lifts Builder into a Writer monad, applied to ().+type Put = PutM ()++type Putter a = a -> Put++instance Functor PutM where+        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w+        {-# INLINE fmap #-}+++instance Applicative PutM where+        pure    = return+        {-# INLINE pure #-}++        m <*> k = Put $+            let PairS f w  = unPut m+                PairS x w' = unPut k+            in PairS (f x) (w `mappend` w')+        {-# INLINE (<*>) #-}+++instance Monad PutM where+    return a = Put (PairS a mempty)+    {-# INLINE return #-}++    m >>= k  = Put $+        let PairS a w  = unPut m+            PairS b w' = unPut (k a)+        in PairS b (w `mappend` w')+    {-# INLINE (>>=) #-}++    m >> k  = Put $+        let PairS _ w  = unPut m+            PairS b w' = unPut k+        in PairS b (w `mappend` w')+    {-# INLINE (>>) #-}++tell :: Putter Builder+tell b = Put $ PairS () b+{-# INLINE tell #-}++putBuilder :: Putter Builder+putBuilder = tell+{-# INLINE putBuilder #-}++-- | Run the 'Put' monad+execPut :: PutM a -> Builder+execPut = sndS . unPut+{-# INLINE execPut #-}++-- | Run the 'Put' monad with a serialiser+runPut :: Put -> S.ByteString+runPut = toByteString . sndS . unPut+{-# INLINE runPut #-}++-- | Run the 'Put' monad with a serialiser and get its result+runPutM :: PutM a -> (a, S.ByteString)+runPutM (Put (PairS f s)) = (f, toByteString s)+{-# INLINE runPutM #-}++------------------------------------------------------------------------++-- | Pop the ByteString we have constructed so far, if any, yielding a+-- new chunk in the result ByteString.+flush               :: Put+flush               = tell B.flush+{-# INLINE flush #-}++-- | Efficiently write a byte into the output buffer+putWord8            :: Putter Word8+putWord8            = tell . B.singleton+{-# INLINE putWord8 #-}++-- | An efficient primitive to write a strict ByteString into the output buffer.+-- It flushes the current buffer, and writes the argument into a new chunk.+putByteString       :: Putter S.ByteString+putByteString       = tell . B.fromByteString+{-# INLINE putByteString #-}++-- | Write a lazy ByteString efficiently, simply appending the lazy+-- ByteString chunks to the output buffer+putLazyByteString   :: Putter L.ByteString+putLazyByteString   = tell . B.fromLazyByteString+{-# INLINE putLazyByteString #-}++-- | Write a Word16 in big endian format+putWord16be         :: Putter Word16+putWord16be         = tell . B.putWord16be+{-# INLINE putWord16be #-}++-- | Write a Word16 in little endian format+putWord16le         :: Putter Word16+putWord16le         = tell . B.putWord16le+{-# INLINE putWord16le #-}++-- | Write a Word32 in big endian format+putWord32be         :: Putter Word32+putWord32be         = tell . B.putWord32be+{-# INLINE putWord32be #-}++-- | Write a Word32 in little endian format+putWord32le         :: Putter Word32+putWord32le         = tell . B.putWord32le+{-# INLINE putWord32le #-}++-- | Write a Word64 in big endian format+putWord64be         :: Putter Word64+putWord64be         = tell . B.putWord64be+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le         :: Putter Word64+putWord64le         = tell . B.putWord64le+{-# INLINE putWord64le #-}++------------------------------------------------------------------------++-- | /O(1)./ Write a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost         :: Putter Word+putWordhost         = tell . B.putWordhost+{-# INLINE putWordhost #-}++-- | /O(1)./ Write a Word16 in native host order and host endianness.+-- For portability issues see @putWordhost@.+putWord16host       :: Putter Word16+putWord16host       = tell . B.putWord16host+{-# INLINE putWord16host #-}++-- | /O(1)./ Write a Word32 in native host order and host endianness.+-- For portability issues see @putWordhost@.+putWord32host       :: Putter Word32+putWord32host       = tell . B.putWord32host+{-# INLINE putWord32host #-}++-- | /O(1)./ Write a Word64 in native host order+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- For portability issues see @putWordhost@.+putWord64host       :: Putter Word64+putWord64host       = tell . B.putWord64host+{-# INLINE putWord64host #-}+++-- Containers ------------------------------------------------------------------++putTwoOf :: Putter a -> Putter b -> Putter (a,b)+putTwoOf pa pb (a,b) = pa a >> pb b+{-# INLINE putTwoOf #-}++putListOf :: Putter a -> Putter [a]+putListOf pa = go 0 (return ())+  where+  go n body []     = putWord64be n >> body+  go n body (x:xs) = n' `seq` go n' (body >> pa x) xs+    where n' = n + 1+{-# INLINE putListOf #-}++putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e)+putIArrayOf pix pe a = do+  putTwoOf pix pix (bounds a)+  putListOf pe (elems a)+{-# INLINE putIArrayOf #-}++putSeqOf :: Putter a -> Putter (Seq.Seq a)+putSeqOf pa = go 0 (return ())+  where+  go n body s = case Seq.viewl s of+    Seq.EmptyL  -> putWord64be n >> body+    a Seq.:< as -> n' `seq` go n' (body >> pa a) as+      where n' = n + 1+{-# INLINE putSeqOf #-}++putTreeOf :: Putter a -> Putter (T.Tree a)+putTreeOf pa (T.Node r s) = pa r >> putListOf (putTreeOf pa) s+{-# INLINE putTreeOf #-}++putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a)+putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList+{-# INLINE putMapOf #-}++putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap.IntMap a)+putIntMapOf pix pa = putListOf (putTwoOf pix pa) . IntMap.toAscList+{-# INLINE putIntMapOf #-}++putSetOf :: Putter a -> Putter (Set.Set a)+putSetOf pa = putListOf pa . Set.toAscList+{-# INLINE putSetOf #-}++putIntSetOf :: Putter Int -> Putter IntSet.IntSet+putIntSetOf pix = putListOf pix . IntSet.toAscList+{-# INLINE putIntSetOf #-}++putMaybeOf :: Putter a -> Putter (Maybe a)+putMaybeOf _  Nothing  = putWord8 0+putMaybeOf pa (Just a) = putWord8 1 >> pa a+{-# INLINE putMaybeOf #-}++putEitherOf :: Putter a -> Putter b -> Putter (Either a b)+putEitherOf pa _  (Left a)  = putWord8 0 >> pa a+putEitherOf _  pb (Right b) = putWord8 1 >> pb b+{-# INLINE putEitherOf #-}
+ tests/Benchmark.hs view
@@ -0,0 +1,1461 @@+{-# LANGUAGE BangPatterns #-}+module Main (main) where++import qualified Data.ByteString as L+import Data.Serialize+import Data.Serialize.Put+import Data.Serialize.Get++import Control.Exception+import System.CPUTime+import Numeric+import Text.Printf+import System.Environment++import MemBench++data Endian+    = Big+    | Little+    | Host+    deriving (Eq,Ord,Show)++main :: IO ()+main = do+  mb <- getArgs >>= readIO . head+  memBench (mb*10) +  putStrLn ""+  putStrLn "Binary (de)serialisation benchmarks:"++  -- do bytewise +  sequence_+    [ test wordSize chunkSize Host mb+    | wordSize  <- [1]+    , chunkSize <- [16] --1,2,4,8,16]+    ]++  -- now Word16 .. Word64+  sequence_+    [ test wordSize chunkSize end mb+    | wordSize  <- [2,4,8]+    , chunkSize <- [16]+    , end       <- [Host] -- ,Big,Little]+    ]++------------------------------------------------------------------------++time :: IO a -> IO Double+time action = do+    start <- getCPUTime+    action+    end   <- getCPUTime+    return $! (fromIntegral (end - start)) / (10^12)++------------------------------------------------------------------------++test :: Int -> Int -> Endian -> Int -> IO ()+test wordSize chunkSize end mb = do+    let bytes :: Int+        bytes = mb * 2^20+        iterations = bytes `div` wordSize+        bs  = runPut (doPut wordSize chunkSize end iterations)+        sum = runGet (doGet wordSize chunkSize end iterations) bs++    case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return ()++    printf "%dMB of Word%-2d in chunks of %2d (%6s endian): "+        (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)++    putSeconds <- time $ evaluate (L.length bs)+    getSeconds <- time $ evaluate sum+--    print (L.length bs, sum)+    let putThroughput = fromIntegral mb / putSeconds+        getThroughput = fromIntegral mb / getSeconds++    printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n"+           putThroughput+           getThroughput+           (getThroughput/putThroughput)++------------------------------------------------------------------------++doPut :: Int -> Int -> Endian -> Int -> Put+doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of+    (1, 1,_)   -> putWord8N1+    (1, 2,_)   -> putWord8N2+    (1, 4,_)   -> putWord8N4+    (1, 8,_)   -> putWord8N8+    (1, 16, _) -> putWord8N16++    (2, 1,  Big)    -> putWord16N1Big+    (2, 2,  Big)    -> putWord16N2Big+    (2, 4,  Big)    -> putWord16N4Big+    (2, 8,  Big)    -> putWord16N8Big+    (2, 16, Big)    -> putWord16N16Big+    (2, 1,  Little) -> putWord16N1Little+    (2, 2,  Little) -> putWord16N2Little+    (2, 4,  Little) -> putWord16N4Little+    (2, 8,  Little) -> putWord16N8Little+    (2, 16, Little) -> putWord16N16Little+    (2, 1,  Host)   -> putWord16N1Host+    (2, 2,  Host)   -> putWord16N2Host+    (2, 4,  Host)   -> putWord16N4Host+    (2, 8,  Host)   -> putWord16N8Host+    (2, 16, Host)   -> putWord16N16Host++    (4, 1,  Big)    -> putWord32N1Big+    (4, 2,  Big)    -> putWord32N2Big+    (4, 4,  Big)    -> putWord32N4Big+    (4, 8,  Big)    -> putWord32N8Big+    (4, 16, Big)    -> putWord32N16Big+    (4, 1,  Little) -> putWord32N1Little+    (4, 2,  Little) -> putWord32N2Little+    (4, 4,  Little) -> putWord32N4Little+    (4, 8,  Little) -> putWord32N8Little+    (4, 16, Little) -> putWord32N16Little+    (4, 1,  Host)   -> putWord32N1Host+    (4, 2,  Host)   -> putWord32N2Host+    (4, 4,  Host)   -> putWord32N4Host+    (4, 8,  Host)   -> putWord32N8Host+    (4, 16, Host)   -> putWord32N16Host++    (8, 1,  Host)        -> putWord64N1Host+    (8, 2,  Host)        -> putWord64N2Host+    (8, 4,  Host)        -> putWord64N4Host+    (8, 8,  Host)        -> putWord64N8Host+    (8, 16, Host)        -> putWord64N16Host+    (8, 1,  Big)         -> putWord64N1Big+    (8, 2,  Big)         -> putWord64N2Big+    (8, 4,  Big)         -> putWord64N4Big+    (8, 8,  Big)         -> putWord64N8Big+    (8, 16, Big)         -> putWord64N16Big+    (8, 1,  Little)      -> putWord64N1Little+    (8, 2,  Little)      -> putWord64N2Little+    (8, 4,  Little)      -> putWord64N4Little+    (8, 8,  Little)      -> putWord64N8Little+    (8, 16, Little)      -> putWord64N16Little++------------------------------------------------------------------------++doGet :: Int -> Int -> Endian -> Int -> Get Int+doGet wordSize chunkSize end =+  case (wordSize, chunkSize, end) of+    (1, 1,_)  -> fmap fromIntegral . getWord8N1+    (1, 2,_)  -> fmap fromIntegral . getWord8N2+    (1, 4,_)  -> fmap fromIntegral . getWord8N4+    (1, 8,_)  -> fmap fromIntegral . getWord8N8+    (1, 16,_) -> fmap fromIntegral . getWord8N16++    (2, 1,Big)      -> fmap fromIntegral . getWord16N1Big+    (2, 2,Big)      -> fmap fromIntegral . getWord16N2Big+    (2, 4,Big)      -> fmap fromIntegral . getWord16N4Big+    (2, 8,Big)      -> fmap fromIntegral . getWord16N8Big+    (2, 16,Big)     -> fmap fromIntegral . getWord16N16Big+    (2, 1,Little)   -> fmap fromIntegral . getWord16N1Little+    (2, 2,Little)   -> fmap fromIntegral . getWord16N2Little+    (2, 4,Little)   -> fmap fromIntegral . getWord16N4Little+    (2, 8,Little)   -> fmap fromIntegral . getWord16N8Little+    (2, 16,Little)  -> fmap fromIntegral . getWord16N16Little+    (2, 1,Host)     -> fmap fromIntegral . getWord16N1Host+    (2, 2,Host)     -> fmap fromIntegral . getWord16N2Host+    (2, 4,Host)     -> fmap fromIntegral . getWord16N4Host+    (2, 8,Host)     -> fmap fromIntegral . getWord16N8Host+    (2, 16,Host)    -> fmap fromIntegral . getWord16N16Host++    (4, 1,Big)      -> fmap fromIntegral . getWord32N1Big+    (4, 2,Big)      -> fmap fromIntegral . getWord32N2Big+    (4, 4,Big)      -> fmap fromIntegral . getWord32N4Big+    (4, 8,Big)      -> fmap fromIntegral . getWord32N8Big+    (4, 16,Big)     -> fmap fromIntegral . getWord32N16Big+    (4, 1,Little)   -> fmap fromIntegral . getWord32N1Little+    (4, 2,Little)   -> fmap fromIntegral . getWord32N2Little+    (4, 4,Little)   -> fmap fromIntegral . getWord32N4Little+    (4, 8,Little)   -> fmap fromIntegral . getWord32N8Little+    (4, 16,Little)  -> fmap fromIntegral . getWord32N16Little+    (4, 1,Host)     -> fmap fromIntegral . getWord32N1Host+    (4, 2,Host)     -> fmap fromIntegral . getWord32N2Host+    (4, 4,Host)     -> fmap fromIntegral . getWord32N4Host+    (4, 8,Host)     -> fmap fromIntegral . getWord32N8Host+    (4, 16,Host)    -> fmap fromIntegral . getWord32N16Host++    (8, 1,Host)     -> fmap fromIntegral . getWord64N1Host+    (8, 2,Host)     -> fmap fromIntegral . getWord64N2Host+    (8, 4,Host)     -> fmap fromIntegral . getWord64N4Host+    (8, 8,Host)     -> fmap fromIntegral . getWord64N8Host+    (8, 16,Host)    -> fmap fromIntegral . getWord64N16Host+    (8, 1,Big)      -> fmap fromIntegral . getWord64N1Big+    (8, 2,Big)      -> fmap fromIntegral . getWord64N2Big+    (8, 4,Big)      -> fmap fromIntegral . getWord64N4Big+    (8, 8,Big)      -> fmap fromIntegral . getWord64N8Big+    (8, 16,Big)     -> fmap fromIntegral . getWord64N16Big+    (8, 1,Little)   -> fmap fromIntegral . getWord64N1Little+    (8, 2,Little)   -> fmap fromIntegral . getWord64N2Little+    (8, 4,Little)   -> fmap fromIntegral . getWord64N4Little+    (8, 8,Little)   -> fmap fromIntegral . getWord64N8Little+    (8, 16,Little)  -> fmap fromIntegral . getWord64N16Little++------------------------------------------------------------------------++putWord8N1 bytes = loop 0 0+  where loop :: Word8 -> Int -> Put+        loop !s !n | n == bytes = return ()+                   | otherwise  = do putWord8 s+                                     loop (s+1) (n+1)++putWord8N2 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          loop (s+2) (n-2)++putWord8N4 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          loop (s+4) (n-4)++putWord8N8 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          putWord8 (s+4)+          putWord8 (s+5)+          putWord8 (s+6)+          putWord8 (s+7)+          loop (s+8) (n-8)++putWord8N16 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord8 (s+0)+          putWord8 (s+1)+          putWord8 (s+2)+          putWord8 (s+3)+          putWord8 (s+4)+          putWord8 (s+5)+          putWord8 (s+6)+          putWord8 (s+7)+          putWord8 (s+8)+          putWord8 (s+9)+          putWord8 (s+10)+          putWord8 (s+11)+          putWord8 (s+12)+          putWord8 (s+13)+          putWord8 (s+14)+          putWord8 (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Big endian, word16 writes++putWord16N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          loop (s+1) (n-1)++putWord16N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          loop (s+2) (n-2)++putWord16N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          loop (s+4) (n-4)++putWord16N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          putWord16be (s+4)+          putWord16be (s+5)+          putWord16be (s+6)+          putWord16be (s+7)+          loop (s+8) (n-8)++putWord16N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16be (s+0)+          putWord16be (s+1)+          putWord16be (s+2)+          putWord16be (s+3)+          putWord16be (s+4)+          putWord16be (s+5)+          putWord16be (s+6)+          putWord16be (s+7)+          putWord16be (s+8)+          putWord16be (s+9)+          putWord16be (s+10)+          putWord16be (s+11)+          putWord16be (s+12)+          putWord16be (s+13)+          putWord16be (s+14)+          putWord16be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Little endian, word16 writes++putWord16N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          loop (s+1) (n-1)++putWord16N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          loop (s+2) (n-2)++putWord16N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          loop (s+4) (n-4)++putWord16N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          putWord16le (s+4)+          putWord16le (s+5)+          putWord16le (s+6)+          putWord16le (s+7)+          loop (s+8) (n-8)++putWord16N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16le (s+0)+          putWord16le (s+1)+          putWord16le (s+2)+          putWord16le (s+3)+          putWord16le (s+4)+          putWord16le (s+5)+          putWord16le (s+6)+          putWord16le (s+7)+          putWord16le (s+8)+          putWord16le (s+9)+          putWord16le (s+10)+          putWord16le (s+11)+          putWord16le (s+12)+          putWord16le (s+13)+          putWord16le (s+14)+          putWord16le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+-- Host endian, unaligned, word16 writes++putWord16N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          loop (s+1) (n-1)++putWord16N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          loop (s+2) (n-2)++putWord16N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          loop (s+4) (n-4)++putWord16N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          putWord16host (s+4)+          putWord16host (s+5)+          putWord16host (s+6)+          putWord16host (s+7)+          loop (s+8) (n-8)++putWord16N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord16host (s+0)+          putWord16host (s+1)+          putWord16host (s+2)+          putWord16host (s+3)+          putWord16host (s+4)+          putWord16host (s+5)+          putWord16host (s+6)+          putWord16host (s+7)+          putWord16host (s+8)+          putWord16host (s+9)+          putWord16host (s+10)+          putWord16host (s+11)+          putWord16host (s+12)+          putWord16host (s+13)+          putWord16host (s+14)+          putWord16host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          loop (s+1) (n-1)++putWord32N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          loop (s+2) (n-2)++putWord32N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          loop (s+4) (n-4)++putWord32N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          putWord32be (s+4)+          putWord32be (s+5)+          putWord32be (s+6)+          putWord32be (s+7)+          loop (s+8) (n-8)++putWord32N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32be (s+0)+          putWord32be (s+1)+          putWord32be (s+2)+          putWord32be (s+3)+          putWord32be (s+4)+          putWord32be (s+5)+          putWord32be (s+6)+          putWord32be (s+7)+          putWord32be (s+8)+          putWord32be (s+9)+          putWord32be (s+10)+          putWord32be (s+11)+          putWord32be (s+12)+          putWord32be (s+13)+          putWord32be (s+14)+          putWord32be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          loop (s+1) (n-1)++putWord32N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          loop (s+2) (n-2)++putWord32N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          loop (s+4) (n-4)++putWord32N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          putWord32le (s+4)+          putWord32le (s+5)+          putWord32le (s+6)+          putWord32le (s+7)+          loop (s+8) (n-8)++putWord32N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32le (s+0)+          putWord32le (s+1)+          putWord32le (s+2)+          putWord32le (s+3)+          putWord32le (s+4)+          putWord32le (s+5)+          putWord32le (s+6)+          putWord32le (s+7)+          putWord32le (s+8)+          putWord32le (s+9)+          putWord32le (s+10)+          putWord32le (s+11)+          putWord32le (s+12)+          putWord32le (s+13)+          putWord32le (s+14)+          putWord32le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          loop (s+1) (n-1)++putWord32N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          loop (s+2) (n-2)++putWord32N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          loop (s+4) (n-4)++putWord32N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          putWord32host (s+4)+          putWord32host (s+5)+          putWord32host (s+6)+          putWord32host (s+7)+          loop (s+8) (n-8)++putWord32N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord32host (s+0)+          putWord32host (s+1)+          putWord32host (s+2)+          putWord32host (s+3)+          putWord32host (s+4)+          putWord32host (s+5)+          putWord32host (s+6)+          putWord32host (s+7)+          putWord32host (s+8)+          putWord32host (s+9)+          putWord32host (s+10)+          putWord32host (s+11)+          putWord32host (s+12)+          putWord32host (s+13)+          putWord32host (s+14)+          putWord32host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          loop (s+1) (n-1)++putWord64N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          loop (s+2) (n-2)++putWord64N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          loop (s+4) (n-4)++putWord64N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          putWord64be (s+4)+          putWord64be (s+5)+          putWord64be (s+6)+          putWord64be (s+7)+          loop (s+8) (n-8)++putWord64N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64be (s+0)+          putWord64be (s+1)+          putWord64be (s+2)+          putWord64be (s+3)+          putWord64be (s+4)+          putWord64be (s+5)+          putWord64be (s+6)+          putWord64be (s+7)+          putWord64be (s+8)+          putWord64be (s+9)+          putWord64be (s+10)+          putWord64be (s+11)+          putWord64be (s+12)+          putWord64be (s+13)+          putWord64be (s+14)+          putWord64be (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          loop (s+1) (n-1)++putWord64N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          loop (s+2) (n-2)++putWord64N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          loop (s+4) (n-4)++putWord64N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          putWord64le (s+4)+          putWord64le (s+5)+          putWord64le (s+6)+          putWord64le (s+7)+          loop (s+8) (n-8)++putWord64N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64le (s+0)+          putWord64le (s+1)+          putWord64le (s+2)+          putWord64le (s+3)+          putWord64le (s+4)+          putWord64le (s+5)+          putWord64le (s+6)+          putWord64le (s+7)+          putWord64le (s+8)+          putWord64le (s+9)+          putWord64le (s+10)+          putWord64le (s+11)+          putWord64le (s+12)+          putWord64le (s+13)+          putWord64le (s+14)+          putWord64le (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          loop (s+1) (n-1)++putWord64N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          loop (s+2) (n-2)++putWord64N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          loop (s+4) (n-4)++putWord64N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          putWord64host (s+4)+          putWord64host (s+5)+          putWord64host (s+6)+          putWord64host (s+7)+          loop (s+8) (n-8)++putWord64N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop _ 0 = return ()+        loop s n = do+          putWord64host (s+0)+          putWord64host (s+1)+          putWord64host (s+2)+          putWord64host (s+3)+          putWord64host (s+4)+          putWord64host (s+5)+          putWord64host (s+6)+          putWord64host (s+7)+          putWord64host (s+8)+          putWord64host (s+9)+          putWord64host (s+10)+          putWord64host (s+11)+          putWord64host (s+12)+          putWord64host (s+13)+          putWord64host (s+14)+          putWord64host (s+15)+          loop (s+16) (n-16)++------------------------------------------------------------------------+------------------------------------------------------------------------++getWord8N1 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          loop (s+s0) (n-1)++getWord8N2 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          loop (s+s0+s1) (n-2)++getWord8N4 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          loop (s+s0+s1+s2+s3) (n-4)++getWord8N8 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N16 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          s1 <- getWord8+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          s8 <- getWord8+          s9 <- getWord8+          s10 <- getWord8+          s11 <- getWord8+          s12 <- getWord8+          s13 <- getWord8+          s14 <- getWord8+          s15 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          loop (s+s0) (n-1)++getWord16N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          loop (s+s0+s1) (n-2)++getWord16N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          s4 <- getWord16be+          s5 <- getWord16be+          s6 <- getWord16be+          s7 <- getWord16be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16be+          s1 <- getWord16be+          s2 <- getWord16be+          s3 <- getWord16be+          s4 <- getWord16be+          s5 <- getWord16be+          s6 <- getWord16be+          s7 <- getWord16be+          s8 <- getWord16be+          s9 <- getWord16be+          s10 <- getWord16be+          s11 <- getWord16be+          s12 <- getWord16be+          s13 <- getWord16be+          s14 <- getWord16be+          s15 <- getWord16be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          loop (s+s0) (n-1)++getWord16N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          loop (s+s0+s1) (n-2)++getWord16N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          s4 <- getWord16le+          s5 <- getWord16le+          s6 <- getWord16le+          s7 <- getWord16le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16le+          s1 <- getWord16le+          s2 <- getWord16le+          s3 <- getWord16le+          s4 <- getWord16le+          s5 <- getWord16le+          s6 <- getWord16le+          s7 <- getWord16le+          s8 <- getWord16le+          s9 <- getWord16le+          s10 <- getWord16le+          s11 <- getWord16le+          s12 <- getWord16le+          s13 <- getWord16le+          s14 <- getWord16le+          s15 <- getWord16le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          loop (s+s0) (n-1)++getWord16N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          loop (s+s0+s1) (n-2)++getWord16N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          s4 <- getWord16host+          s5 <- getWord16host+          s6 <- getWord16host+          s7 <- getWord16host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord16host+          s1 <- getWord16host+          s2 <- getWord16host+          s3 <- getWord16host+          s4 <- getWord16host+          s5 <- getWord16host+          s6 <- getWord16host+          s7 <- getWord16host+          s8 <- getWord16host+          s9 <- getWord16host+          s10 <- getWord16host+          s11 <- getWord16host+          s12 <- getWord16host+          s13 <- getWord16host+          s14 <- getWord16host+          s15 <- getWord16host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          loop (s+s0) (n-1)++getWord32N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          loop (s+s0+s1) (n-2)++getWord32N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          s4 <- getWord32be+          s5 <- getWord32be+          s6 <- getWord32be+          s7 <- getWord32be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32be+          s1 <- getWord32be+          s2 <- getWord32be+          s3 <- getWord32be+          s4 <- getWord32be+          s5 <- getWord32be+          s6 <- getWord32be+          s7 <- getWord32be+          s8 <- getWord32be+          s9 <- getWord32be+          s10 <- getWord32be+          s11 <- getWord32be+          s12 <- getWord32be+          s13 <- getWord32be+          s14 <- getWord32be+          s15 <- getWord32be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          loop (s+s0) (n-1)++getWord32N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          loop (s+s0+s1) (n-2)++getWord32N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          s4 <- getWord32le+          s5 <- getWord32le+          s6 <- getWord32le+          s7 <- getWord32le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32le+          s1 <- getWord32le+          s2 <- getWord32le+          s3 <- getWord32le+          s4 <- getWord32le+          s5 <- getWord32le+          s6 <- getWord32le+          s7 <- getWord32le+          s8 <- getWord32le+          s9 <- getWord32le+          s10 <- getWord32le+          s11 <- getWord32le+          s12 <- getWord32le+          s13 <- getWord32le+          s14 <- getWord32le+          s15 <- getWord32le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          loop (s+s0) (n-1)++getWord32N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          loop (s+s0+s1) (n-2)++getWord32N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          s4 <- getWord32host+          s5 <- getWord32host+          s6 <- getWord32host+          s7 <- getWord32host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord32host+          s1 <- getWord32host+          s2 <- getWord32host+          s3 <- getWord32host+          s4 <- getWord32host+          s5 <- getWord32host+          s6 <- getWord32host+          s7 <- getWord32host+          s8 <- getWord32host+          s9 <- getWord32host+          s10 <- getWord32host+          s11 <- getWord32host+          s12 <- getWord32host+          s13 <- getWord32host+          s14 <- getWord32host+          s15 <- getWord32host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          loop (s+s0) (n-1)++getWord64N2Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          loop (s+s0+s1) (n-2)++getWord64N4Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          s4 <- getWord64be+          s5 <- getWord64be+          s6 <- getWord64be+          s7 <- getWord64be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Big = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64be+          s1 <- getWord64be+          s2 <- getWord64be+          s3 <- getWord64be+          s4 <- getWord64be+          s5 <- getWord64be+          s6 <- getWord64be+          s7 <- getWord64be+          s8 <- getWord64be+          s9 <- getWord64be+          s10 <- getWord64be+          s11 <- getWord64be+          s12 <- getWord64be+          s13 <- getWord64be+          s14 <- getWord64be+          s15 <- getWord64be+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          loop (s+s0) (n-1)++getWord64N2Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          loop (s+s0+s1) (n-2)++getWord64N4Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          s4 <- getWord64le+          s5 <- getWord64le+          s6 <- getWord64le+          s7 <- getWord64le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Little = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64le+          s1 <- getWord64le+          s2 <- getWord64le+          s3 <- getWord64le+          s4 <- getWord64le+          s5 <- getWord64le+          s6 <- getWord64le+          s7 <- getWord64le+          s8 <- getWord64le+          s9 <- getWord64le+          s10 <- getWord64le+          s11 <- getWord64le+          s12 <- getWord64le+          s13 <- getWord64le+          s14 <- getWord64le+          s15 <- getWord64le+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          loop (s+s0) (n-1)++getWord64N2Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          loop (s+s0+s1) (n-2)++getWord64N4Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          s4 <- getWord64host+          s5 <- getWord64host+          s6 <- getWord64host+          s7 <- getWord64host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Host = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord64host+          s1 <- getWord64host+          s2 <- getWord64host+          s3 <- getWord64host+          s4 <- getWord64host+          s5 <- getWord64host+          s6 <- getWord64host+          s7 <- getWord64host+          s8 <- getWord64host+          s9 <- getWord64host+          s10 <- getWord64host+          s11 <- getWord64host+          s12 <- getWord64host+          s13 <- getWord64host+          s14 <- getWord64host+          s15 <- getWord64host+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+ tests/CBenchmark.c view
@@ -0,0 +1,39 @@+#include "CBenchmark.h"++void bytewrite(unsigned char *a, int bytes) {+  unsigned char n = 0;+  int i = 0;+  int iterations = bytes;+  while (i < iterations) {+    a[i++] = n++;+  }+}++unsigned char byteread(unsigned char *a, int bytes) {+  unsigned char n = 0;+  int i = 0;+  int iterations = bytes;+  while (i < iterations) {+    n += a[i++];+  }+  return n;+}++void wordwrite(unsigned long *a, int bytes) {+  unsigned long n = 0;+  int i = 0;+  int iterations = bytes / sizeof(unsigned long) ;+  while (i < iterations) {+    a[i++] = n++;+  }+}++unsigned int wordread(unsigned long *a, int bytes) {+  unsigned long n = 0;+  int i = 0;+  int iterations = bytes / sizeof(unsigned long);+  while (i < iterations) {+    n += a[i++];+  }+  return n;+}
+ tests/CBenchmark.h view
@@ -0,0 +1,4 @@+void bytewrite(unsigned char *a, int bytes);+unsigned char byteread(unsigned char *a, int bytes);+void wordwrite(unsigned long *a, int bytes);+unsigned int wordread(unsigned long *a, int bytes);
+ tests/Makefile view
@@ -0,0 +1,19 @@+GHC	= ghc -O2 -fasm -fforce-recomp++all: bench qc++bench:: Benchmark.hs MemBench.hs CBenchmark.o+	$(GHC) -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@+	./$@ 100++CBenchmark.o: CBenchmark.c+	gcc -O3 -c $< -o $@++qc: Tests.hs+	$(GHC) --make $< -o $@+	./$@++clean:+	$(RM) *.o *.hi bench qc++.PHONY: clean bench bench-nb
+ tests/MemBench.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}+module MemBench (memBench) where++import Foreign+import Foreign.C++import Control.Exception+import System.CPUTime+import Numeric++memBench :: Int -> IO ()+memBench mb = do+  let bytes = mb * 2^20+  allocaBytes bytes $ \ptr -> do+    let bench label test = do+          seconds <- time $ test (castPtr ptr) (fromIntegral bytes)+          let throughput = fromIntegral mb / seconds+          putStrLn $ show mb ++ "MB of " ++ label+                  ++ " in " ++ showFFloat (Just 3) seconds "s, at: "+                  ++ showFFloat (Just 1) throughput "MB/s"+    bench "setup        " c_wordwrite+    putStrLn ""+    putStrLn "C memory throughput benchmarks:"+    bench "bytes written" c_bytewrite+    bench "bytes read   " c_byteread+    bench "words written" c_wordwrite+    bench "words read   " c_wordread+    putStrLn ""+    putStrLn "Haskell memory throughput benchmarks:"+    bench "bytes written" hs_bytewrite+    bench "bytes read   " hs_byteread+    bench "words written" hs_wordwrite+    bench "words read   " hs_wordread++hs_bytewrite  :: Ptr CUChar -> Int -> IO ()+hs_bytewrite !ptr bytes = loop 0 0+  where iterations = bytes+        loop :: Int -> CUChar -> IO ()+        loop !i !n | i == iterations = return ()+                   | otherwise = do pokeByteOff ptr i n+                                    loop (i+1) (n+1)++hs_byteread  :: Ptr CUChar -> Int -> IO CUChar+hs_byteread !ptr bytes = loop 0 0+  where iterations = bytes+        loop :: Int -> CUChar -> IO CUChar+        loop !i !n | i == iterations = return n+                   | otherwise = do x <- peekByteOff ptr i+                                    loop (i+1) (n+x)++hs_wordwrite :: Ptr CULong -> Int -> IO ()+hs_wordwrite !ptr bytes = loop 0 0+  where iterations = bytes `div` sizeOf (undefined :: CULong)+        loop :: Int -> CULong -> IO ()+        loop !i !n | i == iterations = return ()+                   | otherwise = do pokeByteOff ptr i n+                                    loop (i+1) (n+1)++hs_wordread  :: Ptr CULong -> Int -> IO CULong+hs_wordread !ptr bytes = loop 0 0+  where iterations = bytes `div` sizeOf (undefined :: CULong)+        loop :: Int -> CULong -> IO CULong+        loop !i !n | i == iterations = return n+                   | otherwise = do x <- peekByteOff ptr i+                                    loop (i+1) (n+x)+++foreign import ccall unsafe "CBenchmark.h byteread"+  c_byteread :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h bytewrite"+  c_bytewrite :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordread"+  c_wordread :: Ptr CUInt -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordwrite"+  c_wordwrite :: Ptr CUInt -> CInt -> IO ()++time :: IO a -> IO Double+time action = do+    start <- getCPUTime+    action+    end   <- getCPUTime+    return $! (fromIntegral (end - start)) / (10^12)
+ tests/Tests.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ExistentialQuantification #-}++--------------------------------------------------------------------------------+-- |+-- Module      : +-- Copyright   : (c) Galois, Inc, 2009+-- License     : AllRightsReserved+--+-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   : +-- Portability : +--++import Data.Serialize+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Word (Word8)+import Test.QuickCheck++instance Arbitrary Word8 where+  arbitrary = arbitraryBoundedIntegral++instance Arbitrary Word16 where+  arbitrary = arbitraryBoundedIntegral++instance Arbitrary Word32 where+  arbitrary = arbitraryBoundedIntegral++instance Arbitrary Word64 where+  arbitrary = arbitraryBoundedIntegral+++roundTrip :: Eq a => Putter a -> Get a -> a -> Bool+roundTrip p g a = res == Right a+  where res = runGet g (runPut (p a))++main :: IO ()+main  = mapM_ quickCheck+  [ label "Word8         Round Trip" $ roundTrip putWord8      getWord8+  , label "Word16be      Round Trip" $ roundTrip putWord16be   getWord16be+  , label "Word16le      Round Trip" $ roundTrip putWord16le   getWord16le+  , label "Word32be      Round Trip" $ roundTrip putWord32be   getWord32be+  , label "Word32le      Round Trip" $ roundTrip putWord32le   getWord32le+  , label "Word64be      Round Trip" $ roundTrip putWord64be   getWord64be+  , label "Word64le      Round Trip" $ roundTrip putWord64le   getWord64le+  , label "Word16host    Round Trip" $ roundTrip putWord16host getWord16host+  , label "Word32host    Round Trip" $ roundTrip putWord32host getWord32host+  , label "Word64host    Round Trip" $ roundTrip putWord64host getWord64host++    -- Containers+  , label "(Word8,Word8) Round Trip"+    $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8)+  , label "[Word8] Round Trip"+    $ roundTrip (putListOf putWord8) (getListOf getWord8)+  , label "Maybe Word8 Round Trip"+    $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8)+  , label "Either Word8 Word16be Round Trip "+    $ roundTrip (putEitherOf putWord8 putWord16be)+                (getEitherOf getWord8 getWord16be)+  ]