haskus-binary 1.5 → 1.6
raw patch · 24 files changed
+970/−1333 lines, 24 filesdep −megaparsecdep −mtl
Dependencies removed: megaparsec, mtl
Files
- haskus-binary.cabal +1/−3
- src/lib/Haskus/Binary/BitField.hs +14/−25
- src/lib/Haskus/Binary/Bits/Bitwise.hs +54/−0
- src/lib/Haskus/Binary/Bits/Finite.hs +52/−0
- src/lib/Haskus/Binary/Bits/Get.hs +37/−18
- src/lib/Haskus/Binary/Bits/Index.hs +29/−0
- src/lib/Haskus/Binary/Bits/Put.hs +30/−9
- src/lib/Haskus/Binary/Bits/Shift.hs +166/−4
- src/lib/Haskus/Binary/Enum.hs +14/−1
- src/lib/Haskus/Binary/Get.hs +1/−1
- src/lib/Haskus/Binary/Record.hs +7/−7
- src/lib/Haskus/Binary/Serialize/Buffer.hs +40/−45
- src/lib/Haskus/Binary/Serialize/File.hs +10/−5
- src/lib/Haskus/Binary/Serialize/Get.hs +2/−2
- src/lib/Haskus/Binary/Serialize/Put.hs +1/−1
- src/lib/Haskus/Binary/Serialize/Size.hs +24/−6
- src/lib/Haskus/Binary/Union.hs +1/−1
- src/lib/Haskus/Binary/Unum.hs +0/−2
- src/lib/Haskus/Memory/Allocator/Malloc.hs +21/−27
- src/lib/Haskus/Memory/Buffer.hs +416/−1098
- src/lib/Haskus/Memory/Embed.hs +19/−47
- src/lib/Haskus/Memory/Typed.hs +1/−1
- src/lib/Haskus/Memory/View.hs +29/−30
- src/lib/Haskus/Number/Posit.hs +1/−0
haskus-binary.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: haskus-binary-version: 1.5+version: 1.6 synopsis: Haskus binary format manipulation license: BSD-3-Clause license-file: LICENSE@@ -91,8 +91,6 @@ , haskus-utils >= 1.4 , cereal >= 0.5 , bytestring >= 0.10- , mtl >= 2.2- , megaparsec , template-haskell , transformers , directory
src/lib/Haskus/Binary/BitField.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-} -- | Bit fields (as in C) --@@ -64,21 +65,7 @@ -- w = BitFields 0x0102 -- @ ---module Haskus.Binary.BitField- ( BitFields (..)- , bitFieldsBits- , BitField (..)- , extractField- , extractField'- , updateField- , updateField'- , withField- , withField'- , matchFields- , matchNamedFields- , Field- )-where+module Haskus.Binary.BitField where import Haskus.Binary.BitSet as BitSet import Haskus.Binary.Enum@@ -90,8 +77,10 @@ import Haskus.Utils.Types import Haskus.Utils.Tuple +import Data.Typeable+ -- | Bit fields on a base type b-newtype BitFields b (f :: [*]) = BitFields b deriving (Storable)+newtype BitFields b (f :: [Type]) = BitFields b deriving (Storable) -- | Get backing word bitFieldsBits :: BitFields b f -> b@@ -100,10 +89,10 @@ -- | A field of n bits-newtype BitField (n :: Nat) (name :: Symbol) s = BitField s deriving (Storable)+newtype BitField (n :: Nat) (name :: nk) s = BitField s deriving (Storable) -- | Get the bit offset of a field from its name-type family Offset (name :: Symbol) fs :: Nat where+type family Offset name fs :: Nat where Offset name (BitField n name s ': xs) = AddOffset xs Offset name (BitField n name2 s ': xs) = Offset name xs @@ -112,12 +101,12 @@ AddOffset (BitField n name s ': xs) = n + AddOffset xs -- | Get the type of a field from its name-type family Output (name :: Symbol) fs :: * where+type family Output name fs :: Type where Output name (BitField n name s ': xs) = s Output name (BitField n name2 s ': xs) = Output name xs -- | Get the size of a field from it name-type family Size (name :: Symbol) fs :: Nat where+type family Size name fs :: Nat where Size name (BitField n name s ': xs) = n Size name (BitField n name2 s ': xs) = Size name xs @@ -189,7 +178,7 @@ toField = toEnumField . toCEnum -- | Get the value of a field-extractField :: forall (name :: Symbol) fields b .+extractField :: forall name fields b . ( KnownNat (Offset name fields) , KnownNat (Size name fields) , WholeSize fields ~ BitSize b@@ -200,7 +189,7 @@ extractField = extractField' @name -- | Get the value of a field (without checking sizes)-extractField' :: forall (name :: Symbol) fields b .+extractField' :: forall name fields b . ( KnownNat (Offset name fields) , KnownNat (Size name fields) , Bits b, Integral b@@ -252,7 +241,7 @@ withField = withField' @name -- | Modify the value of a field (without checking sizes)-withField' :: forall (name :: Symbol) fields b f .+withField' :: forall name fields b f . ( KnownNat (Offset name fields) , KnownNat (Size name fields) , Bits b, Integral b@@ -291,9 +280,9 @@ , b ~ BitField n name s -- the current field , i ~ HList l2 -- input type , r ~ HList (String ': l2) -- result type- , KnownSymbol name+ , Typeable name ) => Apply Name (b, i) r where- apply _ (_, xs) = HCons (symbolValue @name) xs+ apply _ (_, xs) = HCons (show (typeRep (Proxy :: Proxy name))) xs fieldValues :: forall l l2 w bs . ( bs ~ BitFields w l
src/lib/Haskus/Binary/Bits/Bitwise.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} @@ -12,6 +13,11 @@ import GHC.Exts import GHC.Num +#if MIN_VERSION_GLASGOW_HASKELL (9,0,0,0)+import GHC.Natural+import GHC.Integer+#endif+ -- | Bitwise bit operations class Bitwise a where -- | Bitwise "and"@@ -30,24 +36,48 @@ (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) instance Bitwise Word8 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (W8# x#) .&. (W8# y#) = W8# (x# `andWord8#` y#)+ (W8# x#) .|. (W8# y#) = W8# (x# `orWord8#` y#)+ (W8# x#) `xor` (W8# y#) = W8# (x# `xorWord8#` y#)+#else (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#)+#endif instance Bitwise Word16 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (W16# x#) .&. (W16# y#) = W16# (x# `andWord16#` y#)+ (W16# x#) .|. (W16# y#) = W16# (x# `orWord16#` y#)+ (W16# x#) `xor` (W16# y#) = W16# (x# `xorWord16#` y#)+#else (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#)+#endif instance Bitwise Word32 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (W32# x#) .&. (W32# y#) = W32# (x# `andWord32#` y#)+ (W32# x#) .|. (W32# y#) = W32# (x# `orWord32#` y#)+ (W32# x#) `xor` (W32# y#) = W32# (x# `xorWord32#` y#)+#else (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#)+#endif instance Bitwise Word64 where+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0)+ (W64# x#) .&. (W64# y#) = W64# (x# `and64#` y#)+ (W64# x#) .|. (W64# y#) = W64# (x# `or64#` y#)+ (W64# x#) `xor` (W64# y#) = W64# (x# `xor64#` y#)+#else (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#)+#endif instance Bitwise Int where (I# x#) .&. (I# y#) = I# (x# `andI#` y#)@@ -55,24 +85,48 @@ (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) instance Bitwise Int8 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I8# x#) .&. (I8# y#) = I8# (intToInt8# (int8ToInt# x# `andI#` int8ToInt# y#))+ (I8# x#) .|. (I8# y#) = I8# (intToInt8# (int8ToInt# x# `orI#` int8ToInt# y#))+ (I8# x#) `xor` (I8# y#) = I8# (intToInt8# (int8ToInt# x# `xorI#` int8ToInt# y#))+#else (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#)) (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#)) (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))+#endif instance Bitwise Int16 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I16# x#) .&. (I16# y#) = I16# (intToInt16# (int16ToInt# x# `andI#` int16ToInt# y#))+ (I16# x#) .|. (I16# y#) = I16# (intToInt16# (int16ToInt# x# `orI#` int16ToInt# y#))+ (I16# x#) `xor` (I16# y#) = I16# (intToInt16# (int16ToInt# x# `xorI#` int16ToInt# y#))+#else (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#)) (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#)) (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))+#endif instance Bitwise Int32 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I32# x#) .&. (I32# y#) = I32# (intToInt32# (int32ToInt# x# `andI#` int32ToInt# y#))+ (I32# x#) .|. (I32# y#) = I32# (intToInt32# (int32ToInt# x# `orI#` int32ToInt# y#))+ (I32# x#) `xor` (I32# y#) = I32# (intToInt32# (int32ToInt# x# `xorI#` int32ToInt# y#))+#else (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#)) (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#)) (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))+#endif instance Bitwise Int64 where+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0)+ (I64# x#) .&. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))+ (I64# x#) .|. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `or64#` int64ToWord64# y#))+ (I64# x#) `xor` (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#))+#else (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#)) (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#)) (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))+#endif instance Bitwise Integer where (.&.) = andInteger
src/lib/Haskus/Binary/Bits/Finite.hs view
@@ -62,37 +62,65 @@ type BitSize Word8 = 8 zeroBits = 0 oneBits = maxBound+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (W8# x#) = W# (clz8# (word8ToWord# x#))+ countTrailingZeros (W8# x#) = W# (ctz8# (word8ToWord# x#))+ complement (W8# x#) = W8# (x# `xorWord8#` mb#)+ where !(W8# mb#) = maxBound+#else countLeadingZeros (W8# x#) = W# (clz8# x#) countTrailingZeros (W8# x#) = W# (ctz8# x#) complement (W8# x#) = W8# (x# `xor#` mb#) where !(W8# mb#) = maxBound+#endif instance FiniteBits Word16 where type BitSize Word16 = 16 zeroBits = 0 oneBits = maxBound+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (W16# x#) = W# (clz16# (word16ToWord# x#))+ countTrailingZeros (W16# x#) = W# (ctz16# (word16ToWord# x#))+ complement (W16# x#) = W16# (x# `xorWord16#` mb#)+ where !(W16# mb#) = maxBound+#else countLeadingZeros (W16# x#) = W# (clz16# x#) countTrailingZeros (W16# x#) = W# (ctz16# x#) complement (W16# x#) = W16# (x# `xor#` mb#) where !(W16# mb#) = maxBound+#endif instance FiniteBits Word32 where type BitSize Word32 = 32 zeroBits = 0 oneBits = maxBound+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (W32# x#) = W# (clz32# (word32ToWord# x#))+ countTrailingZeros (W32# x#) = W# (ctz32# (word32ToWord# x#))+ complement (W32# x#) = W32# (x# `xorWord32#` mb#)+ where !(W32# mb#) = maxBound+#else countLeadingZeros (W32# x#) = W# (clz32# x#) countTrailingZeros (W32# x#) = W# (ctz32# x#) complement (W32# x#) = W32# (x# `xor#` mb#) where !(W32# mb#) = maxBound+#endif instance FiniteBits Word64 where type BitSize Word64 = 64 zeroBits = 0 oneBits = maxBound+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0) countLeadingZeros (W64# x#) = W# (clz64# x#) countTrailingZeros (W64# x#) = W# (ctz64# x#)+ complement (W64# x#) = W64# (x# `xor64#` mb#)+ where !(W64# mb#) = maxBound+#else+ countLeadingZeros (W64# x#) = W# (clz64# x#)+ countTrailingZeros (W64# x#) = W# (ctz64# x#) complement (W64# x#) = W64# (x# `xor#` mb#) where !(W64# mb#) = maxBound+#endif instance FiniteBits Int where@@ -107,30 +135,54 @@ type BitSize Int8 = 8 zeroBits = 0 oneBits = (-1)+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (I8# x#) = W# (clz8# (int2Word# (int8ToInt# x#)))+ countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# (int8ToInt# x#)))+ complement (I8# x#) = I8# (intToInt8# (notI# (int8ToInt# x#)))+#else countLeadingZeros (I8# x#) = W# (clz8# (int2Word# x#)) countTrailingZeros (I8# x#) = W# (ctz8# (int2Word# x#)) complement (I8# x#) = I8# (word2Int# (not# (int2Word# x#)))+#endif instance FiniteBits Int16 where type BitSize Int16 = 16 zeroBits = 0 oneBits = (-1)+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (I16# x#) = W# (clz16# (int2Word# (int16ToInt# x#)))+ countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# (int16ToInt# x#)))+ complement (I16# x#) = I16# (intToInt16# (notI# (int16ToInt# x#)))+#else countLeadingZeros (I16# x#) = W# (clz16# (int2Word# x#)) countTrailingZeros (I16# x#) = W# (ctz16# (int2Word# x#)) complement (I16# x#) = I16# (word2Int# (not# (int2Word# x#)))+#endif instance FiniteBits Int32 where type BitSize Int32 = 32 zeroBits = 0 oneBits = (-1)+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ countLeadingZeros (I32# x#) = W# (clz32# (int2Word# (int32ToInt# x#)))+ countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# (int32ToInt# x#)))+ complement (I32# x#) = I32# (intToInt32# (notI# (int32ToInt# x#)))+#else countLeadingZeros (I32# x#) = W# (clz32# (int2Word# x#)) countTrailingZeros (I32# x#) = W# (ctz32# (int2Word# x#)) complement (I32# x#) = I32# (word2Int# (not# (int2Word# x#)))+#endif instance FiniteBits Int64 where type BitSize Int64 = 64 zeroBits = 0 oneBits = (-1)+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0)+ countLeadingZeros (I64# x#) = W# (clz64# (int64ToWord64# x#))+ countTrailingZeros (I64# x#) = W# (ctz64# (int64ToWord64# x#))+ complement (I64# x#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# (intToInt64# (-1#))))+#else countLeadingZeros (I64# x#) = W# (clz64# (int2Word# x#)) countTrailingZeros (I64# x#) = W# (ctz64# (int2Word# x#)) complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+#endif
src/lib/Haskus/Binary/Bits/Get.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveFunctor #-} -- | Bit getter module Haskus.Binary.Bits.Get@@ -33,10 +35,10 @@ where import System.IO.Unsafe (unsafePerformIO)-import Control.Monad.State-import Control.Monad.Identity+import Data.Functor.Identity import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr+import Control.Monad import Haskus.Binary.Buffer import Haskus.Binary.Bits.Order@@ -148,59 +150,76 @@ -- | BitGet monad transformer-type BitGetT m a = StateT BitGetState m a+newtype BitGetT m a+ = BitGetT (BitGetState -> m (BitGetState, a))+ deriving (Functor) +instance Monad m => Applicative (BitGetT m) where+ pure a = BitGetT (\s -> pure (s,a))+ (BitGetT f) <*> (BitGetT a) =+ BitGetT \s -> do+ (s',f') <- f s+ (s'',a') <- a s'+ pure (s'', f' a')++instance Monad m => Monad (BitGetT m) where+ BitGetT a >>= f = BitGetT \s -> do+ (s', a') <- a s+ case f a' of+ BitGetT r -> r s'+ -- | BitGet monad type BitGet a = BitGetT Identity a -- | Evaluate a BitGet monad runBitGetT :: Monad m => BitOrder -> BitGetT m a -> Buffer -> m a-runBitGetT bo m bs = evalStateT m (newBitGetState bo bs)+runBitGetT bo m bs = snd <$> runBitGetPartialT bo m bs + -- | Evaluate a BitGet monad runBitGet :: BitOrder -> BitGet a -> Buffer -> a runBitGet bo m bs = runIdentity (runBitGetT bo m bs) -- | Evaluate a BitGet monad, return the remaining state-runBitGetPartialT :: BitOrder -> BitGetT m a -> Buffer -> m (a, BitGetState)-runBitGetPartialT bo m bs = runStateT m (newBitGetState bo bs)+runBitGetPartialT :: Functor m => BitOrder -> BitGetT m a -> Buffer -> m (BitGetState,a)+runBitGetPartialT bo (BitGetT m) bs = m (newBitGetState bo bs) -- | Evaluate a BitGet monad, return the remaining state-runBitGetPartial :: BitOrder -> BitGet a -> Buffer -> (a, BitGetState)+runBitGetPartial :: BitOrder -> BitGet a -> Buffer -> (BitGetState,a) runBitGetPartial bo m bs = runIdentity (runBitGetPartialT bo m bs) -- | Resume a BitGet evaluation-resumeBitGetPartialT :: BitGetT m a -> BitGetState -> m (a, BitGetState)-resumeBitGetPartialT = runStateT +resumeBitGetPartialT :: BitGetT m a -> BitGetState -> m (BitGetState,a)+resumeBitGetPartialT (BitGetT m) s = m s -- | Resume a BitGet evaluation-resumeBitGetPartial :: BitGet a -> BitGetState -> (a,BitGetState)+resumeBitGetPartial :: BitGet a -> BitGetState -> (BitGetState,a) resumeBitGetPartial m s = runIdentity (resumeBitGetPartialT m s) -- | Indicate if all bits have been read isEmptyM :: Monad m => BitGetT m Bool-isEmptyM = gets isEmpty+isEmptyM = BitGetT \s -> pure (s,isEmpty s) -- | Skip the given number of bits from the input (monadic version) skipBitsM :: Monad m => Word -> BitGetT m ()-skipBitsM = modify . skipBits+skipBitsM n = BitGetT \s -> pure (skipBits n s, ()) -- | Skip the required number of bits to be aligned on 8-bits (monadic version) skipBitsToAlignOnWord8M :: Monad m => BitGetT m ()-skipBitsToAlignOnWord8M = modify skipBitsToAlignOnWord8+skipBitsToAlignOnWord8M = BitGetT \s -> pure (skipBitsToAlignOnWord8 s, ()) -- | Read the given number of bits and put the result in a word getBitsM :: (Integral a, Bits a, Monad m) => Word -> BitGetT m a getBitsM n = do- v <- gets (getBits n)+ v <- BitGetT \s -> pure (s, getBits n s) skipBitsM n return v -- | Perform some checks before calling getBitsM getBitsCheckedM :: (Integral a, Bits a, ReversableBits a, Monad m) => Word -> Word -> BitGetT m a getBitsCheckedM m n = do- v <- gets (getBitsChecked m n)+ v <- BitGetT \s -> pure (s, getBitsChecked m n s) skipBitsM n return v @@ -213,7 +232,7 @@ -- | Get the given number of Word8 getBitsBSM :: (Monad m) => Word -> BitGetT m Buffer getBitsBSM n = do- bs <- gets (getBitsBuffer n)+ bs <- BitGetT \s -> pure (s, getBitsBuffer n s) skipBitsM (8*n) return bs @@ -222,14 +241,14 @@ -- Be careful to change the outer bit ordering (B* to L* or the inverse) only -- on bytes boundaries! Otherwise, you will read the same bits more than once. changeBitGetOrder :: Monad m => BitOrder -> BitGetT m ()-changeBitGetOrder bo = modify (\s -> s { bitGetStateBitOrder = bo })+changeBitGetOrder bo = BitGetT \s -> pure (s { bitGetStateBitOrder = bo }, ()) -- | Change the bit ordering for the wrapped BitGet -- -- Be careful, this function uses changeBitGetOrder internally. withBitGetOrder :: Monad m => BitOrder -> BitGetT m a -> BitGetT m a withBitGetOrder bo m = do- bo' <- gets bitGetStateBitOrder+ bo' <- BitGetT \s -> pure (s, bitGetStateBitOrder s) changeBitGetOrder bo v <- m changeBitGetOrder bo'
src/lib/Haskus/Binary/Bits/Index.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}@@ -58,13 +59,25 @@ popCount (W# x#) = W# (popCnt# x#) instance IndexableBits Word8 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (W8# x#) = W# (popCnt8# (word8ToWord# x#))+#else popCount (W8# x#) = W# (popCnt8# x#)+#endif instance IndexableBits Word16 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (W16# x#) = W# (popCnt16# (word16ToWord# x#))+#else popCount (W16# x#) = W# (popCnt16# x#)+#endif instance IndexableBits Word32 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (W32# x#) = W# (popCnt32# (word32ToWord# x#))+#else popCount (W32# x#) = W# (popCnt32# x#)+#endif instance IndexableBits Word64 where popCount (W64# x#) = W# (popCnt64# x#)@@ -73,16 +86,32 @@ popCount (I# x#) = W# (popCnt# (int2Word# x#)) instance IndexableBits Int8 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (I8# x#) = W# (popCnt8# (int2Word# (int8ToInt# x#)))+#else popCount (I8# x#) = W# (popCnt8# (int2Word# x#))+#endif instance IndexableBits Int16 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (I16# x#) = W# (popCnt16# (int2Word# (int16ToInt# x#)))+#else popCount (I16# x#) = W# (popCnt16# (int2Word# x#))+#endif instance IndexableBits Int32 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ popCount (I32# x#) = W# (popCnt32# (int2Word# (int32ToInt# x#)))+#else popCount (I32# x#) = W# (popCnt32# (int2Word# x#))+#endif instance IndexableBits Int64 where+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0)+ popCount (I64# x#) = W# (popCnt64# (int64ToWord64# x#))+#else popCount (I64# x#) = W# (popCnt64# (int2Word# x#))+#endif instance IndexableBits Integer where -- we don't have access to Integer primitive (we would have to conditionally
src/lib/Haskus/Binary/Bits/Put.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BlockArguments #-} -- | Bit putter module Haskus.Binary.Bits.Put@@ -21,8 +23,7 @@ ) where -import Control.Monad.State-import Control.Monad.Identity+import Data.Functor.Identity import Haskus.Binary.BufferBuilder as B import Haskus.Binary.Buffer@@ -131,14 +132,30 @@ getBitPutBuffer = toBuffer . bitPutStateBuilder . flushIncomplete -- | BitPut monad transformer-type BitPutT m a = StateT BitPutState m a+newtype BitPutT m a+ = BitPutT (BitPutState -> m (BitPutState, a))+ deriving (Functor) +instance Monad m => Applicative (BitPutT m) where+ pure a = BitPutT (\s -> pure (s,a))+ (BitPutT f) <*> (BitPutT a) =+ BitPutT \s -> do+ (s',f') <- f s+ (s'',a') <- a s'+ pure (s'', f' a')++instance Monad m => Monad (BitPutT m) where+ BitPutT a >>= f = BitPutT \s -> do+ (s', a') <- a s+ case f a' of+ BitPutT r -> r s'+ -- | BitPut monad-type BitPut a = BitPutT Identity a+type BitPut a = BitPutT Identity a -- | Evaluate a BitPut monad runBitPutT :: Monad m => BitOrder -> BitPutT m a -> m Buffer-runBitPutT bo m = getBitPutBuffer <$> execStateT m (newBitPutState bo)+runBitPutT bo (BitPutT m) = (getBitPutBuffer . fst) <$> m (newBitPutState bo) -- | Evaluate a BitPut monad runBitPut :: BitOrder -> BitPut a -> Buffer@@ -146,7 +163,7 @@ -- | Put bits (monadic) putBitsM :: (Monad m, Integral a, Bits a, ReversableBits a) => Word -> a -> BitPutT m ()-putBitsM n w = modify (putBits n w)+putBitsM n w = BitPutT (\s -> pure (putBits n w s, ())) -- | Put a single bit (monadic) putBitBoolM :: (Monad m) => Bool -> BitPutT m ()@@ -154,21 +171,25 @@ -- | Put a Buffer (monadic) putBitsBufferM :: Monad m => Buffer -> BitPutT m ()-putBitsBufferM bs = modify (putBitsBuffer bs)+putBitsBufferM bs = BitPutT (\s -> pure (putBitsBuffer bs s, ())) -- | Change the current bit ordering -- -- Be careful to change the outer bit ordering (B* to L* or the inverse) only -- on bytes boundaries! Otherwise, you will write the same bits more than once. changeBitPutOrder :: Monad m => BitOrder -> BitPutT m ()-changeBitPutOrder bo = modify (\s -> s { bitPutStateBitOrder = bo })+changeBitPutOrder bo = BitPutT (\s -> pure (s { bitPutStateBitOrder = bo },())) +-- | Get bit order+getBitOrder :: Applicative m => BitPutT m BitOrder+getBitOrder = BitPutT (\s -> pure (s,bitPutStateBitOrder s))+ -- | Change the bit ordering for the wrapped BitPut -- -- Be careful, this function uses changeBitPutOrder internally. withBitPutOrder :: Monad m => BitOrder -> BitPutT m a -> BitPutT m a withBitPutOrder bo m = do- bo' <- gets bitPutStateBitOrder+ bo' <- getBitOrder changeBitPutOrder bo v <- m changeBitPutOrder bo'
src/lib/Haskus/Binary/Bits/Shift.hs view
@@ -15,6 +15,23 @@ #include "MachDeps.h" +#if !MIN_VERSION_GLASGOW_HASKELL (9,0,0,0)+wordToInt# :: Word -> Int#+wordToInt# (W# w) = word2Int# w++integerShiftL :: Integer -> Word -> Integer+integerShiftL x w = shiftLInteger x (wordToInt# w)++integerShiftR :: Integer -> Word -> Integer+integerShiftR x w = shiftRInteger x (wordToInt# w)++naturalShiftL :: Natural -> Word -> Natural+naturalShiftL x w = shiftLNatural x (fromIntegral w)++naturalShiftR :: Natural -> Word -> Natural+naturalShiftR x w = shiftRNatural x (fromIntegral w)+#endif+ -- | Bit shifts -- -- "Checked" means that there is an additional test to ensure that the shift@@ -107,7 +124,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (W8# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 8##) = W8# (wordToWord8# 0##)+ | otherwise = W8# (x# `uncheckedShiftLWord8#` word2Int# i#)++ (W8# x#) `uncheckedShiftL` (W# i#) = W8# (x# `uncheckedShiftLWord8#` word2Int# i#)+ + (W8# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 8##) = W8# (wordToWord8# 0##)+ | otherwise = W8# (x# `uncheckedShiftRLWord8#` word2Int# i#)+ + (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRLWord8#` word2Int# i#)+#else+ (W8# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 8##) = W8# 0## | otherwise = W8# (narrow8Word# (x# `uncheckedShiftL#` word2Int# i#)) @@ -118,6 +148,7 @@ | otherwise = W8# (x# `uncheckedShiftRL#` word2Int# i#) (W8# x#) `uncheckedShiftR` (W# i#) = W8# (x# `uncheckedShiftRL#` word2Int# i#)+#endif instance ShiftableBits Word16 where {-# INLINABLE shiftR #-}@@ -125,7 +156,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (W16# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 16##) = W16# (wordToWord16# 0##)+ | otherwise = W16# (x# `uncheckedShiftLWord16#` word2Int# i#)++ (W16# x#) `uncheckedShiftL` (W# i#) = W16# (x# `uncheckedShiftLWord16#` word2Int# i#)+ + (W16# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 16##) = W16# (wordToWord16# 0##)+ | otherwise = W16# (x# `uncheckedShiftRLWord16#` word2Int# i#)+ + (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRLWord16#` word2Int# i#)+#else+ (W16# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 16##) = W16# 0## | otherwise = W16# (narrow16Word# (x# `uncheckedShiftL#` word2Int# i#)) @@ -136,6 +180,7 @@ | otherwise = W16# (x# `uncheckedShiftRL#` word2Int# i#) (W16# x#) `uncheckedShiftR` (W# i#) = W16# (x# `uncheckedShiftRL#` word2Int# i#)+#endif instance ShiftableBits Word32 where {-# INLINABLE shiftR #-}@@ -143,7 +188,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (W32# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 32##) = W32# (wordToWord32# 0##)+ | otherwise = W32# (x# `uncheckedShiftLWord32#` word2Int# i#)++ (W32# x#) `uncheckedShiftL` (W# i#) = W32# (x# `uncheckedShiftLWord32#` word2Int# i#)+ + (W32# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 32##) = W32# (wordToWord32# 0##)+ | otherwise = W32# (x# `uncheckedShiftRLWord32#` word2Int# i#)+ + (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRLWord32#` word2Int# i#)+#else+ (W32# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 32##) = W32# 0## | otherwise = W32# (narrow32Word# (x# `uncheckedShiftL#` word2Int# i#)) @@ -154,6 +212,7 @@ | otherwise = W32# (x# `uncheckedShiftRL#` word2Int# i#) (W32# x#) `uncheckedShiftR` (W# i#) = W32# (x# `uncheckedShiftRL#` word2Int# i#)+#endif instance ShiftableBits Word64 where {-# INLINABLE shiftR #-}@@ -161,7 +220,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0) (W64# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 64##) = W64# (wordToWord64# 0##)+ | otherwise = W64# (x# `uncheckedShiftL64#` word2Int# i#)++ (W64# x#) `uncheckedShiftL` (W# i#) = W64# (x# `uncheckedShiftL64#` word2Int# i#)+ + (W64# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 64##) = W64# (wordToWord64# 0##)+ | otherwise = W64# (x# `uncheckedShiftRL64#` word2Int# i#)+ + (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL64#` word2Int# i#)+#else+ (W64# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 64##) = W64# 0## | otherwise = W64# (x# `uncheckedShiftL#` word2Int# i#) @@ -172,6 +244,7 @@ | otherwise = W64# (x# `uncheckedShiftRL#` word2Int# i#) (W64# x#) `uncheckedShiftR` (W# i#) = W64# (x# `uncheckedShiftRL#` word2Int# i#)+#endif instance ShiftableBits Int where@@ -198,7 +271,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (I8# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 8##) = I8# (intToInt8# 0#)+ | otherwise = I8# (x# `uncheckedShiftLInt8#` word2Int# i#)++ (I8# x#) `uncheckedShiftL` (W# i#) = I8# (x# `uncheckedShiftLInt8#` word2Int# i#)+ + (I8# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 8##) = I8# (intToInt8# 0#)+ | otherwise = I8# (x# `uncheckedShiftRLInt8#` word2Int# i#)++ (I8# x#) `uncheckedShiftR` (W# i#) = I8# (x# `uncheckedShiftRLInt8#` word2Int# i#)+#else+ (I8# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 8##) = I8# 0# | otherwise = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) @@ -209,6 +295,7 @@ | otherwise = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) (I8# x#) `uncheckedShiftR` (W# i#) = I8# (word2Int# (narrow8Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+#endif instance ShiftableBits Int16 where@@ -217,7 +304,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (I16# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 16##) = I16# (intToInt16# 0#)+ | otherwise = I16# (x# `uncheckedShiftLInt16#` word2Int# i#)++ (I16# x#) `uncheckedShiftL` (W# i#) = I16# (x# `uncheckedShiftLInt16#` word2Int# i#)+ + (I16# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 16##) = I16# (intToInt16# 0#)+ | otherwise = I16# (x# `uncheckedShiftRLInt16#` word2Int# i#)++ (I16# x#) `uncheckedShiftR` (W# i#) = I16# (x# `uncheckedShiftRLInt16#` word2Int# i#)+#else+ (I16# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 16##) = I16# 0# | otherwise = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) @@ -228,6 +328,7 @@ | otherwise = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) (I16# x#) `uncheckedShiftR` (W# i#) = I16# (word2Int# (narrow16Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+#endif instance ShiftableBits Int32 where@@ -236,7 +337,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0) (I32# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 32##) = I32# (intToInt32# 0#)+ | otherwise = I32# (x# `uncheckedShiftLInt32#` word2Int# i#)++ (I32# x#) `uncheckedShiftL` (W# i#) = I32# (x# `uncheckedShiftLInt32#` word2Int# i#)+ + (I32# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 32##) = I32# (intToInt32# 0#)+ | otherwise = I32# (x# `uncheckedShiftRLInt32#` word2Int# i#)++ (I32# x#) `uncheckedShiftR` (W# i#) = I32# (x# `uncheckedShiftRLInt32#` word2Int# i#)+#else+ (I32# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 32##) = I32# 0# | otherwise = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) @@ -247,6 +361,7 @@ | otherwise = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#)) (I32# x#) `uncheckedShiftR` (W# i#) = I32# (word2Int# (narrow32Word# (int2Word# x#) `uncheckedShiftRL#` word2Int# i#))+#endif instance ShiftableBits Int64 where {-# INLINABLE shiftR #-}@@ -254,7 +369,20 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} +#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0) (I64# x#) `shiftL` (W# i#)+ | isTrue# (i# `geWord#` 64##) = I64# (intToInt64# 0#)+ | otherwise = I64# (x# `uncheckedIShiftL64#` word2Int# i#)++ (I64# x#) `uncheckedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL64#` word2Int# i#)+ + (I64# x#) `shiftR` (W# i#)+ | isTrue# (i# `geWord#` 64##) = I64# (intToInt64# 0#)+ | otherwise = I64# (x# `uncheckedIShiftRL64#` word2Int# i#)++ (I64# x#) `uncheckedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRL64#` word2Int# i#)+#else+ (I64# x#) `shiftL` (W# i#) | isTrue# (i# `geWord#` 64##) = I64# 0# | otherwise = I64# (x# `uncheckedIShiftL#` word2Int# i#) @@ -265,6 +393,7 @@ | otherwise = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#)) (I64# x#) `uncheckedShiftR` (W# i#) = I64# (word2Int# (int2Word# x# `uncheckedShiftRL#` word2Int# i#))+#endif instance SignedShiftableBits Int where@@ -274,28 +403,61 @@ (I# x#) `uncheckedSignedShiftR` (W# i#) = I# (x# `uncheckedIShiftRA#` word2Int# i#) instance SignedShiftableBits Int8 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I8# x#) `signedShiftL` (W# i#) = I8# (intToInt8# (int8ToInt# x# `iShiftL#` word2Int# i#))+ (I8# x#) `signedShiftR` (W# i#) = I8# (intToInt8# (int8ToInt# x# `iShiftRA#` word2Int# i#))+ (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (x# `uncheckedShiftLInt8#` word2Int# i#)+ (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedShiftRAInt8#` word2Int# i#)+#else (I8# x#) `signedShiftL` (W# i#) = I8# (narrow8Int# (x# `iShiftL#` word2Int# i#)) (I8# x#) `signedShiftR` (W# i#) = I8# (x# `iShiftRA#` word2Int# i#) (I8# x#) `uncheckedSignedShiftL` (W# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` word2Int# i#)) (I8# x#) `uncheckedSignedShiftR` (W# i#) = I8# (x# `uncheckedIShiftRA#` word2Int# i#)+#endif instance SignedShiftableBits Int16 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I16# x#) `signedShiftL` (W# i#) = I16# (intToInt16# (int16ToInt# x# `iShiftL#` word2Int# i#))+ (I16# x#) `signedShiftR` (W# i#) = I16# (intToInt16# (int16ToInt# x# `iShiftRA#` word2Int# i#))+ (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (x# `uncheckedShiftLInt16#` word2Int# i#)+ (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedShiftRAInt16#` word2Int# i#)+#else (I16# x#) `signedShiftL` (W# i#) = I16# (narrow16Int# (x# `iShiftL#` word2Int# i#)) (I16# x#) `signedShiftR` (W# i#) = I16# (x# `iShiftRA#` word2Int# i#) (I16# x#) `uncheckedSignedShiftL` (W# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` word2Int# i#)) (I16# x#) `uncheckedSignedShiftR` (W# i#) = I16# (x# `uncheckedIShiftRA#` word2Int# i#)+#endif instance SignedShiftableBits Int32 where+#if MIN_VERSION_GLASGOW_HASKELL (9,2,0,0)+ (I32# x#) `signedShiftL` (W# i#) = I32# (intToInt32# (int32ToInt# x# `iShiftL#` word2Int# i#))+ (I32# x#) `signedShiftR` (W# i#) = I32# (intToInt32# (int32ToInt# x# `iShiftRA#` word2Int# i#))+ (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (x# `uncheckedShiftLInt32#` word2Int# i#)+ (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedShiftRAInt32#` word2Int# i#)+#else (I32# x#) `signedShiftL` (W# i#) = I32# (narrow32Int# (x# `iShiftL#` word2Int# i#)) (I32# x#) `signedShiftR` (W# i#) = I32# (x# `iShiftRA#` word2Int# i#) (I32# x#) `uncheckedSignedShiftL` (W# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` word2Int# i#)) (I32# x#) `uncheckedSignedShiftR` (W# i#) = I32# (x# `uncheckedIShiftRA#` word2Int# i#)+#endif instance SignedShiftableBits Int64 where+#if MIN_VERSION_GLASGOW_HASKELL (9,4,0,0)+ (I64# x#) `signedShiftL` (W# i#)+ = I64# (word64ToInt64#+ ((int64ToWord64# (x# `uncheckedIShiftL64#` word2Int# i#)) `and64#`+ (int64ToWord64# (intToInt64# (negateInt# (i# `ltWord#` 64##))))))+ (I64# x#) `signedShiftR` (W# i#)+ | isTrue# (i# `geWord#` 64##) = I64# (intToInt64# (negateInt# (x# `ltInt64#` intToInt64# 0#)))+ | otherwise = I64# (x# `uncheckedIShiftRA64#` word2Int# i#)+ (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL64#` word2Int# i#)+ (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA64#` word2Int# i#)+#else (I64# x#) `signedShiftL` (W# i#) = I64# (x# `iShiftL#` word2Int# i#) (I64# x#) `signedShiftR` (W# i#) = I64# (x# `iShiftRA#` word2Int# i#) (I64# x#) `uncheckedSignedShiftL` (W# i#) = I64# (x# `uncheckedIShiftL#` word2Int# i#) (I64# x#) `uncheckedSignedShiftR` (W# i#) = I64# (x# `uncheckedIShiftRA#` word2Int# i#)+#endif @@ -305,8 +467,8 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} - x `shiftL` (W# i#) = shiftLInteger x (word2Int# i#)- x `shiftR` (W# i#) = shiftRInteger x (word2Int# i#)+ x `shiftL` w = integerShiftL x w+ x `shiftR` w = integerShiftR x w uncheckedShiftL = shiftL uncheckedShiftR = shiftR@@ -317,8 +479,8 @@ {-# INLINABLE uncheckedShiftL #-} {-# INLINABLE uncheckedShiftR #-} - x `shiftL` (W# i#) = shiftLNatural x (I# (word2Int# i#))- x `shiftR` (W# i#) = shiftRNatural x (I# (word2Int# i#))+ x `shiftL` w = naturalShiftL x w+ x `shiftR` w = naturalShiftR x w uncheckedShiftL = shiftL uncheckedShiftR = shiftR
src/lib/Haskus/Binary/Enum.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeFamilies #-}@@ -22,9 +23,14 @@ import Foreign.Ptr import Data.Data-import GHC.Prim import GHC.Int +#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+import GHC.Magic (DataToTag,dataToTag#)+#else+import GHC.Prim+#endif+ ----------------------------------------------------------------------------- -- EnumField b a: directly store the value of enum "a" as a "b" -----------------------------------------------------------------------------@@ -70,6 +76,9 @@ -- class CEnum a where fromCEnum :: Integral b => a -> b+#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+ default fromCEnum :: (DataToTag a, Integral b) => a -> b+#endif fromCEnum = fromIntegral . dataToTag toCEnum :: Integral b => b -> a@@ -140,5 +149,9 @@ -- >>> data D = A | B | C -- >>> dataToTag B -- 1+#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+dataToTag :: DataToTag a => a -> Int+#else dataToTag :: a -> Int+#endif dataToTag a = I# (dataToTag# a)
src/lib/Haskus/Binary/Get.hs view
@@ -216,7 +216,7 @@ getBitGet :: BitOrder -> BitGet a -> (a -> Get b) -> Get b getBitGet bo bg cont = do bs <- getRemaining- let (v,s) = runBitGetPartial bo (bg <* skipBitsToAlignOnWord8M) bs+ let (s,v) = runBitGetPartial bo (bg <* skipBitsToAlignOnWord8M) bs return $ runGetOrFail (cont v) (bitGetStateInput s) -- | Apply the getter at most 'max' times
src/lib/Haskus/Binary/Record.hs view
@@ -39,13 +39,13 @@ import Haskus.Utils.Types -- | Record-newtype Record (fields :: [*]) = Record (ForeignPtr ())+newtype Record (fields :: [Type]) = Record (ForeignPtr ()) -- | Field data Field (name :: Symbol) typ -- | Get record size without the ending padding bytes-type family RecordSize (fs :: [*]) (sz :: Nat) where+type family RecordSize (fs :: [Type]) (sz :: Nat) where RecordSize '[] sz = sz RecordSize (Field name typ ': fs) sz = RecordSize fs@@ -56,7 +56,7 @@ + SizeOf typ ) -type family FieldOffset (name :: Symbol) (fs :: [*]) (sz :: Nat) where+type family FieldOffset (name :: Symbol) (fs :: [Type]) (sz :: Nat) where -- Found FieldOffset name (Field name typ ': fs) sz = sz + Padding sz typ@@ -65,7 +65,7 @@ FieldOffset name fs (sz + Padding sz typ + SizeOf typ) -type family FieldType (name :: Symbol) (fs :: [*]) where+type family FieldType (name :: Symbol) (fs :: [Type]) where FieldType name (Field name typ ': fs) = typ FieldType name (Field xx typ ': fs) = FieldType name fs @@ -77,21 +77,21 @@ (RecordAlignment fs 1) -- | Record alignment-type family RecordAlignment (fs :: [*]) a where+type family RecordAlignment (fs :: [Type]) a where RecordAlignment '[] a = a RecordAlignment (Field name typ ': fs) a = RecordAlignment fs (If (a <=? Alignment typ) (Alignment typ) a) -- | Return offset from a field path-type family FieldPathOffset (fs :: [*]) (path :: [Symbol]) (off :: Nat) where+type family FieldPathOffset (fs :: [Type]) (path :: [Symbol]) (off :: Nat) where FieldPathOffset fs '[p] off = off + FieldOffset p fs 0 FieldPathOffset fs (p ': ps) off = FieldPathOffset (ExtractRecord (FieldType p fs)) ps (off + FieldOffset p fs 0) -- | Return type from a field path-type family FieldPathType (fs :: [*]) (path :: [Symbol]) where+type family FieldPathType (fs :: [Type]) (path :: [Symbol]) where FieldPathType fs '[p] = FieldType p fs FieldPathType fs (p ': ps)
src/lib/Haskus/Binary/Serialize/Buffer.hs view
@@ -19,7 +19,7 @@ -- >>> xs <- forM [0..4] (bufferReadWord8IO b') -- >>> xs == [0x01,0x23,0x45,0x67,0x89] -- True--- >>> bufferSizeIO b'+-- >>> bufferSize b' -- 16 -- module Haskus.Binary.Serialize.Buffer@@ -78,23 +78,23 @@ -- | Buffer extend strategy: double the buffer size each time and copy the -- original contents in it-overflowBufferDouble :: MonadIO m => OverflowStrategy m BufferM+overflowBufferDouble :: OverflowStrategy IO Buffer overflowBufferDouble = OverflowStrategy \ex -> do- sz <- bufferSizeIO (overflowBuffer ex)+ sz <- bufferSize (overflowBuffer ex) let off = overflowOffset ex req = overflowRequired ex b = overflowBuffer ex makeSzs i = i*i : makeSzs (i*i) -- infinite list of doubling sizes newSz = head <| filter (> req+off) (makeSzs sz) newB <- newBuffer newSz- copyBuffer b 0 newB 0 off+ bufferCopy b 0 newB 0 off pure (newB,off) -- | Buffer extend strategy: double the buffer size each time and copy the -- original contents in it-overflowBufferDoublePinned :: MonadIO m => Maybe Word -> OverflowStrategy m BufferMP+overflowBufferDoublePinned :: Maybe Word -> OverflowStrategy IO Buffer overflowBufferDoublePinned malignment = OverflowStrategy \ex -> do- sz <- bufferSizeIO (overflowBuffer ex)+ sz <- bufferSize (overflowBuffer ex) let off = overflowOffset ex req = overflowRequired ex b = overflowBuffer ex@@ -103,28 +103,28 @@ newB <- case malignment of Nothing -> newPinnedBuffer newSz Just al -> newAlignedPinnedBuffer newSz al- copyBuffer b 0 newB 0 off+ bufferCopy b 0 newB 0 off pure (newB,off) -- | Buffer extend strategy: add the given size each time and copy the -- original contents in it-overflowBufferAdd :: MonadIO m => Word -> OverflowStrategy m BufferM+overflowBufferAdd :: Word -> OverflowStrategy IO Buffer overflowBufferAdd addSz = OverflowStrategy \ex -> do- sz <- bufferSizeIO (overflowBuffer ex)+ sz <- bufferSize (overflowBuffer ex) let off = overflowOffset ex req = overflowRequired ex b = overflowBuffer ex makeSzs i = i+addSz : makeSzs (i+addSz) -- infinite list of added sizes newSz = head <| filter (> req+off) (makeSzs sz) newB <- newBuffer newSz- copyBuffer b 0 newB 0 off+ bufferCopy b 0 newB 0 off pure (newB,off) -- | Buffer extend strategy: add the given size each time and copy the -- original contents in it-overflowBufferAddPinned :: MonadIO m => Maybe Word -> Word -> OverflowStrategy m BufferMP+overflowBufferAddPinned :: Maybe Word -> Word -> OverflowStrategy IO Buffer overflowBufferAddPinned malignment addSz = OverflowStrategy \ex -> do- sz <- bufferSizeIO (overflowBuffer ex)+ sz <- bufferSize (overflowBuffer ex) let off = overflowOffset ex req = overflowRequired ex b = overflowBuffer ex@@ -133,7 +133,7 @@ newB <- case malignment of Nothing -> newPinnedBuffer newSz Just al -> newAlignedPinnedBuffer newSz al- copyBuffer b 0 newB 0 off+ bufferCopy b 0 newB 0 off pure (newB,off) @@ -201,9 +201,9 @@ putSomething :: MonadIO m => Word- -> (Buffer 'Mutable pin fin heap -> Word -> t -> m ())+ -> (Buffer -> Word -> t -> m ()) -> t- -> BufferPutT (Buffer 'Mutable pin fin heap) m ()+ -> BufferPutT Buffer m () {-# INLINABLE putSomething #-} putSomething sz act v = putSomeThings sz $ Just \b off -> act b off v @@ -211,13 +211,13 @@ putSomeThings :: MonadIO m => Word- -> Maybe (Buffer 'Mutable pin fin heap -> Word -> m ())- -> BufferPutT (Buffer 'Mutable pin fin heap) m ()+ -> Maybe (Buffer -> Word -> m ())+ -> BufferPutT Buffer m () {-# INLINABLE putSomeThings #-} putSomeThings sz mact = do off <- getPutOffset b <- getPutBuffer- bs <- liftIO (bufferSizeIO b)+ bs <- liftIO (bufferSize b) let !newOff = off+sz if (newOff > bs)@@ -239,36 +239,33 @@ setPutOffset newOff -instance- ( MonadIO m- ) => PutMonad (BufferPutT (Buffer 'Mutable pin gc heap) m)- where- putWord8 = putSomething 1 bufferWriteWord8IO- putWord16 = putSomething 2 bufferWriteWord16IO- putWord32 = putSomething 4 bufferWriteWord32IO- putWord64 = putSomething 8 bufferWriteWord64IO+instance PutMonad (BufferPutT Buffer IO) where+ putWord8 = putSomething 1 bufferWriteWord8+ putWord16 = putSomething 2 bufferWriteWord16+ putWord32 = putSomething 4 bufferWriteWord32+ putWord64 = putSomething 8 bufferWriteWord64 putWord8s xs = putSomeThings (fromIntegral (length xs)) $ Just \b off -> do forM_ ([off,(off+1)..] `zip` xs) $ \(boff,v) -> do- bufferWriteWord8IO b boff v+ bufferWriteWord8 b boff v putWord16s xs = putSomeThings (2*fromIntegral (length xs)) $ Just \b off -> do forM_ ([off,(off+2)..] `zip` xs) $ \(boff,v) -> do- bufferWriteWord16IO b boff v+ bufferWriteWord16 b boff v putWord32s xs = putSomeThings (4*fromIntegral (length xs)) $ Just \b off -> do forM_ ([off,(off+4)..] `zip` xs) $ \(boff,v) -> do- bufferWriteWord32IO b boff v+ bufferWriteWord32 b boff v putWord64s xs = putSomeThings (8*fromIntegral (length xs)) $ Just \b off -> do forM_ ([off,(off+8)..] `zip` xs) $ \(boff,v) -> do- bufferWriteWord64IO b boff v+ bufferWriteWord64 b boff v preAllocateAtLeast l = putSomeThings l Nothing putBuffer x = do- sz <- liftIO (bufferSizeIO x)- putSomeThings sz $ Just \b off -> copyBuffer x 0 b off sz+ sz <- liftIO (bufferSize x)+ putSomeThings sz $ Just \b off -> bufferCopy x 0 b off sz ---------------------------------------------------------------------- -- BufferGet@@ -288,21 +285,19 @@ type BufferGet b a = BufferGetT b Identity a -instance- ( MonadIO m- ) => GetMonad (BufferGetT (Buffer mut pin gc heap) m)+instance GetMonad (BufferGetT Buffer IO) where getSkipBytes n = getSomething n \_ _ -> return ()- getWord8 = getSomething 1 bufferReadWord8IO- getWord16 = getSomething 2 bufferReadWord16IO- getWord32 = getSomething 4 bufferReadWord32IO- getWord64 = getSomething 8 bufferReadWord64IO+ getWord8 = getSomething 1 bufferReadWord8+ getWord16 = getSomething 2 bufferReadWord16+ getWord32 = getSomething 4 bufferReadWord32+ getWord64 = getSomething 8 bufferReadWord64 getBuffer sz = getSomething sz \b off -> do dest <- newBuffer sz- copyBuffer b off dest 0 sz- unsafeBufferFreeze dest+ bufferCopy b off dest 0 sz+ pure dest getBufferInto sz dest mdoff = getSomething sz \b off -> do- copyBuffer b off dest (fromMaybe 0 mdoff) sz+ bufferCopy b off dest (fromMaybe 0 mdoff) sz -- | Lift into BufferGetT liftBufferGet :: Monad m => m a -> BufferGetT b m a@@ -342,12 +337,12 @@ ( Monad m , MonadIO m ) => Word- -> (Buffer mut pin gc heap -> Word -> m a)- -> BufferGetT (Buffer mut pin gc heap) m a+ -> (Buffer -> Word -> m a)+ -> BufferGetT Buffer m a getSomething sz act = do off <- getGetOffset b <- getGetBuffer- bsz <- bufferSizeIO b+ bsz <- liftIO (bufferSize b) let !newOff = off+sz
src/lib/Haskus/Binary/Serialize/File.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} module Haskus.Binary.Serialize.File ( FileGetState (..)@@ -17,12 +19,15 @@ import Haskus.Utils.Monad import Haskus.Utils.Maybe -import GHC.Exts (Ptr (..))+import GHC.Exts (Ptr (..), Word(..)) import System.IO import Control.Monad.Trans.State.Strict as S-import Control.Monad.Fail as F import Control.Monad.Fix +#if !MIN_VERSION_GLASGOW_HASKELL (8,8,0,0)+import Control.Monad.Fail+#endif+ -- | FileGetT state data FileGetState = FileGetState { fileGetHandle :: !Handle@@ -59,9 +64,9 @@ getWord32 = getSomething 4 peek getWord64 = getSomething 8 peek - getBufferInto sz dest mdoff = getSomething sz \(Ptr addr) -> do- let b = BufferE addr sz- copyBuffer b 0 dest (fromMaybe 0 mdoff) sz+ getBufferInto sz@(W# sz#) dest mdoff = getSomething sz \(Ptr addr) -> do+ let b = attachExternalBuffer addr sz#+ bufferCopy b 0 dest (fromMaybe 0 mdoff) sz -- | Run a getter on a file
src/lib/Haskus/Binary/Serialize/Get.hs view
@@ -64,14 +64,14 @@ getWord64s n = replicateM (fromIntegral n) getWord64 -- | Read the given amount of bytes into a new buffer- getBuffer :: Word -> m BufferI+ getBuffer :: Word -> m Buffer getBuffer n = do xs <- replicateM (fromIntegral n) getWord8 return (fromListN (fromIntegral n) xs) -- | Read the given amount of bytes into the specified buffer at the -- optionally specified offset- getBufferInto :: Word -> Buffer 'Mutable pin gc heap -> Maybe Word -> m ()+ getBufferInto :: Word -> Buffer -> Maybe Word -> m () -- | Skip the given amount of bytes getSkipBytes :: Word -> m ()
src/lib/Haskus/Binary/Serialize/Put.hs view
@@ -64,7 +64,7 @@ putWord64s xs = forM_ xs putWord64 -- | Write the contents of a buffer- putBuffer :: BufferSize (Buffer Immutable pin gc heap) => Buffer Immutable pin gc heap -> m ()+ putBuffer :: Buffer -> m () -- | Pre-allocate at least the given amount of bytes --
src/lib/Haskus/Binary/Serialize/Size.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} module Haskus.Binary.Serialize.Size ( GetSize (..)@@ -13,23 +15,39 @@ import Haskus.Binary.Serialize.Put import Haskus.Memory.Buffer-import Control.Monad.Trans.State.Strict as S+import System.IO.Unsafe+import GHC.Exts newtype GetSize a- = GetSize (State Word a) - deriving newtype (Functor, Applicative, Monad)+ = GetSize (Word# -> (# Word#, a #)) +instance Functor GetSize where+ fmap f (GetSize g) = GetSize \w0 -> case g w0 of+ (# w1, a #) -> (# w1, f a #)++instance Applicative GetSize where+ pure a = GetSize \w -> (# w, a #)+ GetSize f <*> GetSize a = GetSize \w0 -> case f w0 of+ (# w1, f' #) -> case a w1 of+ (# w2, a' #) -> (# w2, f' a' #)++instance Monad GetSize where+ GetSize m >>= f = GetSize \w0 -> case m w0 of+ (# w1, a #) -> case f a of+ GetSize f' -> f' w1+ -- | Increment the current size incSize :: Word -> GetSize ()-incSize x = GetSize (state (\s -> ((),s+x)))+incSize (W# x) = GetSize \w -> (# w `plusWord#` x, () #) -- | Get the total size runGetSize :: GetSize a -> Word-runGetSize (GetSize s) = execState s 0+runGetSize (GetSize s) = case s 0## of+ (# w, _a #) -> W# w instance PutMonad GetSize where putWord8 _ = incSize 1 putWord16 _ = incSize 2 putWord32 _ = incSize 4 putWord64 _ = incSize 8- putBuffer b = incSize (bufferSize b)+ putBuffer b = incSize (unsafePerformIO (bufferSize b))
src/lib/Haskus/Binary/Union.hs view
@@ -75,7 +75,7 @@ -- -- The union is just a pointer to a buffer containing the value(s). The size of -- the buffer is implicitly known from the types in the list.-newtype Union (x :: [*]) = Union (ForeignPtr ()) deriving (Show)+newtype Union (x :: [Type]) = Union (ForeignPtr ()) deriving (Show) -- | Retrieve a union member from its type fromUnion :: (Storable a, Member a l) => Union l -> a
src/lib/Haskus/Binary/Unum.hs view
@@ -79,8 +79,6 @@ import Haskus.Utils.HList import Haskus.Utils.Flow -import Data.Kind (Type)- -- | An Unum -- -- 0 (and its reciprocal) is always included.
src/lib/Haskus/Memory/Allocator/Malloc.hs view
@@ -2,12 +2,12 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} -- | Malloc memory allocator module Haskus.Memory.Allocator.Malloc ( newBuffer , newFinalizedBuffer- , makeFinalized , freeBuffer ) where@@ -15,43 +15,37 @@ import GHC.Exts import Foreign.Ptr (nullPtr) import Haskus.Utils.Monad-import Haskus.Memory.Buffer- ( Buffer(..), BufferME, BufferMEF- , makeFinalizable,addFinalizer- )+import qualified Haskus.Memory.Buffer as B+import Haskus.Memory.Buffer (Buffer) foreign import ccall unsafe "malloc" malloc_ :: Word -> IO (Ptr ()) foreign import ccall unsafe "free" free :: Addr# -> IO () -- | Allocate a new Buffer using system ``malloc``-newBuffer :: MonadIO m => Word -> m (Maybe BufferME)-{-# INLINABLE newBuffer #-}-newBuffer sz = do- p <- liftIO (malloc_ sz)+newBuffer :: Word -> IO (Maybe Buffer)+newBuffer sz@(W# sz#) = do+ p <- malloc_ sz case p == nullPtr of True -> return Nothing False -> case p of- Ptr addr -> return (Just (BufferME addr sz))+ Ptr addr -> pure (Just (B.attachExternalBuffer addr sz#)) -- | Allocate a new finalized buffer using system ``malloc`` and finalized with -- ``free``.-newFinalizedBuffer :: MonadIO m => Word -> m (Maybe BufferMEF)-{-# INLINABLE newFinalizedBuffer #-}-newFinalizedBuffer sz = do- mb <- newBuffer sz- forM mb makeFinalized+newFinalizedBuffer :: Word -> IO (Maybe Buffer)+newFinalizedBuffer sz@(W# sz#) = do+ p <- malloc_ sz+ case p == nullPtr of+ True -> return Nothing+ False -> case p of+ Ptr addr -> do+ b <- B.attachFinalizedBuffer addr sz#+ B.addFinalizer b (free addr)+ pure (Just b) --- | Make a buffer finalized with ``free``-makeFinalized :: MonadIO m => BufferME -> m BufferMEF-{-# INLINABLE makeFinalized #-}-makeFinalized b = do- fb <- makeFinalizable b- case fb of- BufferMEF addr _sz _f -> addFinalizer fb (free addr)- return fb-- -- | Free a malloc-ed Buffer-freeBuffer :: MonadIO m => BufferME -> m ()+freeBuffer :: Buffer -> IO () {-# INLINABLE freeBuffer #-}-freeBuffer (BufferME addr _sz) = liftIO (free addr)+freeBuffer = \case+ B.InBuffer {} -> error "freeBuffer: unexpected managed buffer"+ B.OutBuffer addr _ _ -> liftIO (free addr)
src/lib/Haskus/Memory/Buffer.hs view
@@ -1,1098 +1,416 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnliftedFFITypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE FlexibleContexts #-}---- | A buffer in memory-module Haskus.Memory.Buffer- ( Buffer (..)- , AnyBuffer (..)- -- * Buffer taxonomy- , Pinning (..)- , Finalization (..)- , Mutability (..)- , Heap (..)- , BufferI- , BufferP- , BufferM- , BufferMP- , BufferME- , BufferE- , BufferF- , BufferPF- , BufferMF- , BufferMPF- , BufferMEF- , BufferEF- -- * GHC allocator- , newBuffer- , newPinnedBuffer- , newAlignedPinnedBuffer- -- * Buffer size- , bufferSizeIO- , BufferSize (..)- -- * Buffer freeze/thaw- , Freezable (..)- , Thawable (..)- -- * Buffer address- , bufferIsDynamicallyPinned- , bufferDynamicallyPinned- , withBufferAddr#- , withBufferPtr- , unsafeWithBufferAddr#- , unsafeWithBufferPtr- -- * Buffer read- , bufferReadWord8IO- , bufferReadWord8- , bufferReadWord16IO- , bufferReadWord16- , bufferReadWord32IO- , bufferReadWord32- , bufferReadWord64IO- , bufferReadWord64- -- * Buffer write and copy- , bufferWriteWord8IO- , bufferWriteWord16IO- , bufferWriteWord32IO- , bufferWriteWord64IO- , copyBuffer- -- * Finalizers- , Finalizers- , addFinalizer- , makeFinalizable- , touchBuffer- , touch- -- * Conversions- , bufferToListIO- , BufferToList (..)- )-where--import Haskus.Number.Word-import Haskus.Number.Int-import Haskus.Binary.Storable-import Haskus.Memory.Property-import Haskus.Memory.Utils (memcpy#)-import Haskus.Utils.Monad--import Data.IORef-import System.IO.Unsafe--import GHC.Prim-import GHC.Exts (toList, IsList(..), Ptr (..))-import GHC.Types (IO(..))---- $setup--- >>> :set -XDataKinds--- >>> :set -XTypeApplications--- >>> :set -XFlexibleContexts--- >>> :set -XTypeFamilies--- >>> :set -XScopedTypeVariables--- >>> import Haskus.Binary.Bits---- | A memory buffer-data Buffer (mut :: Mutability) (pin :: Pinning) (fin :: Finalization) (heap :: Heap) where- Buffer :: !ByteArray# -> BufferI- BufferP :: !ByteArray# -> BufferP- BufferM :: !(MutableByteArray# RealWorld) -> BufferM- BufferMP :: !(MutableByteArray# RealWorld) -> BufferMP- BufferME :: Addr# -> {-# UNPACK #-} !Word -> BufferME- BufferE :: Addr# -> {-# UNPACK #-} !Word -> BufferE- BufferF :: !ByteArray# -> {-# UNPACK #-} !Finalizers -> BufferF- BufferPF :: !ByteArray# -> {-# UNPACK #-} !Finalizers -> BufferPF- BufferMF :: !(MutableByteArray# RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMF- BufferMPF :: !(MutableByteArray# RealWorld) -> {-# UNPACK #-} !Finalizers -> BufferMPF- BufferMEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferMEF- BufferEF :: Addr# -> {-# UNPACK #-} !Word -> {-# UNPACK #-} !Finalizers -> BufferEF--type BufferI = Buffer 'Immutable 'NotPinned 'Collected 'Internal-type BufferP = Buffer 'Immutable 'Pinned 'Collected 'Internal-type BufferM = Buffer 'Mutable 'NotPinned 'Collected 'Internal-type BufferMP = Buffer 'Mutable 'Pinned 'Collected 'Internal-type BufferME = Buffer 'Mutable 'Pinned 'NotFinalized 'External-type BufferE = Buffer 'Immutable 'Pinned 'NotFinalized 'External-type BufferF = Buffer 'Immutable 'NotPinned 'Finalized 'Internal-type BufferPF = Buffer 'Immutable 'Pinned 'Finalized 'Internal-type BufferMF = Buffer 'Mutable 'NotPinned 'Finalized 'Internal-type BufferMPF = Buffer 'Mutable 'Pinned 'Finalized 'Internal-type BufferMEF = Buffer 'Mutable 'Pinned 'Finalized 'External-type BufferEF = Buffer 'Immutable 'Pinned 'Finalized 'External---------------------------------------------------------------------- Allocation---------------------------------------------------------------------- | Allocate a buffer (mutable, unpinned)------ >>> b <- newBuffer 1024----newBuffer :: MonadIO m => Word -> m BufferM-{-# INLINABLE newBuffer #-}-newBuffer sz = liftIO $ IO \s ->- case fromIntegral sz of- I# sz# -> case newByteArray# sz# s of- (# s', arr# #) -> (# s', BufferM arr# #)---- | Allocate a buffer (mutable, pinned)-newPinnedBuffer :: MonadIO m => Word -> m BufferMP-{-# INLINABLE newPinnedBuffer #-}-newPinnedBuffer sz = liftIO $ IO \s ->- case fromIntegral sz of- I# sz# -> case newPinnedByteArray# sz# s of- (# s', arr# #) -> (# s', BufferMP arr# #)---- | Allocate an aligned buffer (mutable, pinned)-newAlignedPinnedBuffer :: MonadIO m => Word -> Word -> m BufferMP-{-# INLINABLE newAlignedPinnedBuffer #-}-newAlignedPinnedBuffer sz al = liftIO $ IO \s ->- case fromIntegral sz of- I# sz# -> case fromIntegral al of- I# al# -> case newAlignedPinnedByteArray# sz# al# s of- (# s', arr# #) -> (# s', BufferMP arr# #)----------------------------------------------------------------------- Finalizers--------------------------------------------------------------------newtype Finalizers = Finalizers (IORef [IO ()])---- | Insert a finalizer. Return True if there was no finalizer before-insertFinalizer :: MonadIO m => Finalizers -> IO () -> m Bool-insertFinalizer (Finalizers rfs) f = do- liftIO $ atomicModifyIORef rfs $ \finalizers -> case finalizers of- [] -> ([f] , True)- fs -> (f:fs, False)---- | Get buffer finalizers-getFinalizers :: Buffer mut pin 'Finalized heap -> Finalizers-getFinalizers b = case b of- BufferMEF _addr _sz fin -> fin- BufferEF _addr _sz fin -> fin- BufferF _ba fin -> fin- BufferPF _ba fin -> fin- BufferMF _ba fin -> fin- BufferMPF _ba fin -> fin----- | Add a finalizer.------ The latest added finalizers are executed first. Finalizers are not guaranteed--- to run (e.g. if the program exits before the buffer is collected).----addFinalizer :: MonadIO m => Buffer mut pin 'Finalized heap -> IO () -> m ()-addFinalizer b f = do- let fin@(Finalizers rfs) = getFinalizers b- wasEmpty <- insertFinalizer fin f- -- add the weak reference to the finalizer IORef (not to Addr#/byteArray#/...)- when wasEmpty $ void $ liftIO $ mkWeakIORef rfs (runFinalizers fin)---- | Internal function used to execute finalizers-runFinalizers :: Finalizers -> IO ()-runFinalizers (Finalizers rfs) = do- -- atomically remove finalizers to avoid double execution- fs <- atomicModifyIORef rfs $ \fs -> ([], fs)- sequence_ fs---- | Create empty Finalizers-newFinalizers :: MonadIO m => m Finalizers-newFinalizers = Finalizers <$> liftIO (newIORef [])---- | Touch a buffer-touchBuffer :: MonadIO m => Buffer mut pin fin heap -> m ()-{-# INLINABLE touchBuffer #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferI -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferP -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferM -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMP -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferME -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferE -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferF -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferPF -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMF -> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMPF-> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferMEF-> m () #-}-{-# SPECIALIZE INLINE touchBuffer :: MonadIO m => BufferEF -> m () #-}-touchBuffer (Buffer _ba ) = return ()-touchBuffer (BufferP _ba ) = return ()-touchBuffer (BufferM _ba ) = return ()-touchBuffer (BufferMP _ba ) = return ()-touchBuffer (BufferF _ba (Finalizers fin)) = liftIO $ touch fin-touchBuffer (BufferPF _ba (Finalizers fin)) = liftIO $ touch fin-touchBuffer (BufferMF _ba (Finalizers fin)) = liftIO $ touch fin-touchBuffer (BufferMPF _ba (Finalizers fin)) = liftIO $ touch fin-touchBuffer (BufferME _addr _sz ) = return ()-touchBuffer (BufferE _addr _sz ) = return ()-touchBuffer (BufferMEF _addr _sz (Finalizers fin)) = liftIO $ touch fin-touchBuffer (BufferEF _addr _sz (Finalizers fin)) = liftIO $ touch fin---- | Touch a data-touch :: MonadIO m => a -> m ()-{-# NOINLINE touch #-}-touch x = liftIO $ IO \s -> case touch# x s of- s' -> (# s', () #)---- | Make a buffer finalizable------ The new buffer liveness is used to trigger finalizers.----{-# INLINABLE makeFinalizable #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferI -> m BufferF #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferP -> m BufferPF #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferM -> m BufferMF #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferMP -> m BufferMPF #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferME -> m BufferMEF #-}-{-# SPECIALIZE INLINE makeFinalizable :: MonadIO m => BufferE -> m BufferEF #-}-makeFinalizable :: MonadIO m => Buffer mut pin f heap -> m (Buffer mut pin 'Finalized heap)-makeFinalizable (BufferME addr sz) = BufferMEF addr sz <$> newFinalizers-makeFinalizable (BufferE addr sz) = BufferEF addr sz <$> newFinalizers-makeFinalizable (Buffer ba ) = BufferF ba <$> newFinalizers-makeFinalizable (BufferP ba ) = BufferPF ba <$> newFinalizers-makeFinalizable (BufferM ba ) = BufferMF ba <$> newFinalizers-makeFinalizable (BufferMP ba ) = BufferMPF ba <$> newFinalizers-makeFinalizable x@(BufferF {}) = return x-makeFinalizable x@(BufferMEF{}) = return x-makeFinalizable x@(BufferEF{}) = return x-makeFinalizable x@(BufferPF {}) = return x-makeFinalizable x@(BufferMF {}) = return x-makeFinalizable x@(BufferMPF {}) = return x---------------------------------------------------------------------- Operations---------------------------------------------------------------------- | Buffer that can be frozen (converted from mutable to immutable)-class Freezable a b | a -> b where- -- | Convert a mutable buffer to an immutable one without copying. The- -- buffer should not be modified after the conversion.- unsafeBufferFreeze :: MonadIO m => a -> m b--instance Freezable (Buffer 'Mutable pin 'Collected heap)- (Buffer 'Immutable pin 'Collected heap)- where- {-# INLINABLE unsafeBufferFreeze #-}- unsafeBufferFreeze = \case- BufferM mba -> liftIO $ IO (\s -> case unsafeFreezeByteArray# mba s of (# s', ba #) -> (# s', Buffer ba #))- BufferMP mba -> liftIO $ IO (\s -> case unsafeFreezeByteArray# mba s of (# s', ba #) -> (# s', BufferP ba #))---instance Freezable (Buffer 'Mutable pin fin 'External)- (Buffer 'Immutable pin fin 'External)- where- {-# INLINABLE unsafeBufferFreeze #-}- unsafeBufferFreeze = \case- BufferME addr sz -> return (BufferE addr sz)- -- works because finalizers are attached to the IORef "fin"- BufferMEF addr sz fin -> return (BufferEF addr sz fin)----- | Buffer that can be thawed (converted from immutable to mutable)-class Thawable a b | a -> b where- -- | Convert an immutable buffer to a mutable one without copying. The- -- original buffer should not be used after the conversion.- unsafeBufferThaw :: MonadIO m => a -> m b--instance Thawable (Buffer 'Immutable pin 'Collected heap)- (Buffer 'Mutable pin 'Collected heap)- where- {-# INLINABLE unsafeBufferThaw #-}- unsafeBufferThaw = \case- Buffer mba -> pure $ BufferM (unsafeCoerce# mba)- BufferP mba -> pure $ BufferMP (unsafeCoerce# mba)--instance Thawable (Buffer 'Immutable pin 'NotFinalized heap)- (Buffer 'Mutable pin 'NotFinalized heap)- where- {-# INLINABLE unsafeBufferThaw #-}- unsafeBufferThaw = \case- BufferE addr sz -> return (BufferME addr sz)------ | Some buffers managed by GHC can be pinned as an optimization. This function--- reports this.-bufferIsDynamicallyPinned :: Buffer mut pin fin heap -> Bool-bufferIsDynamicallyPinned = \case- BufferP {} -> True- BufferMP {} -> True- BufferME {} -> True- BufferPF {} -> True- BufferE {} -> True- BufferMEF{} -> True- BufferEF {} -> True- BufferMPF{} -> True- Buffer ba -> isTrue# (isByteArrayPinned# ba)- BufferM mba -> isTrue# (isMutableByteArrayPinned# mba)- BufferF ba _fin -> isTrue# (isByteArrayPinned# ba)- BufferMF mba _fin -> isTrue# (isMutableByteArrayPinned# mba)---- | Transform type-level NotPinned buffers into type-level Pinned if the buffer--- is dynamically pinned (see `bufferIsDynamicallyPinned`).-bufferDynamicallyPinned- :: Buffer mut pin fin heap- -> Either (Buffer mut 'NotPinned fin heap) (Buffer mut 'Pinned fin heap)-bufferDynamicallyPinned b = case b of- BufferP {} -> Right b- BufferMP {} -> Right b- BufferME {} -> Right b- BufferPF {} -> Right b- BufferE {} -> Right b- BufferMEF{} -> Right b- BufferEF {} -> Right b- BufferMPF{} -> Right b- Buffer ba -> if isTrue# (isByteArrayPinned# ba)- then Right (BufferP ba)- else Left b- BufferM mba -> if isTrue# (isMutableByteArrayPinned# mba)- then Right (BufferMP mba)- else Left b- BufferF ba fin -> if isTrue# (isByteArrayPinned# ba)- then Right (BufferPF ba fin)- else Left b- BufferMF mba fin -> if isTrue# (isMutableByteArrayPinned# mba)- then Right (BufferMPF mba fin)- else Left b------ | Do something with a buffer address------ Note: don't write into immutable buffer as it would break referential--- consistency-unsafeWithBufferAddr# :: MonadIO m => Buffer mut 'Pinned fin heap -> (Addr# -> m a) -> m a-{-# INLINABLE unsafeWithBufferAddr# #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferP -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferMP -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferME -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferE -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferPF -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferMPF-> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferMEF-> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferAddr# :: MonadIO m => BufferEF -> (Addr# -> m a) -> m a #-}-unsafeWithBufferAddr# b@(BufferP ba) f = do- r <- f (byteArrayContents# ba)- touchBuffer b- return r-unsafeWithBufferAddr# b@(BufferMP ba) f = do- r <- f (byteArrayContents# (unsafeCoerce# ba))- touchBuffer b- return r-unsafeWithBufferAddr# b@(BufferPF ba _fin) f = do- r <- f (byteArrayContents# ba)- touchBuffer b- return r-unsafeWithBufferAddr# b@(BufferMPF ba _fin) f = do- r <- f (byteArrayContents# (unsafeCoerce# ba))- touchBuffer b- return r-unsafeWithBufferAddr# (BufferME addr _sz) f = f (addr)-unsafeWithBufferAddr# (BufferE addr _sz) f = f (addr)-unsafeWithBufferAddr# b@(BufferMEF addr _sz _fin) f = do- r <- f addr- touchBuffer b- return r-unsafeWithBufferAddr# b@(BufferEF addr _sz _fin) f = do- r <- f addr- touchBuffer b- return r---- | Do something with a buffer pointer------ Note: don't write into immutable buffer as it would break referential--- consistency-unsafeWithBufferPtr :: MonadIO m => Buffer mut 'Pinned fin heap -> (Ptr b -> m a) -> m a-{-# INLINABLE unsafeWithBufferPtr #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferP -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferMP -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferME -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferE -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferPF -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferMPF-> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferMEF-> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE unsafeWithBufferPtr :: MonadIO m => BufferEF -> (Ptr b -> m a) -> m a #-}-unsafeWithBufferPtr b f = unsafeWithBufferAddr# b g- where- g addr = f (Ptr addr)---- | Do something with a buffer address-withBufferAddr# :: MonadIO m => Buffer 'Mutable 'Pinned fin heap -> (Addr# -> m a) -> m a-{-# INLINABLE withBufferAddr# #-}-{-# SPECIALIZE INLINE withBufferAddr# :: MonadIO m => BufferMP -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferAddr# :: MonadIO m => BufferME -> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferAddr# :: MonadIO m => BufferMPF-> (Addr# -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferAddr# :: MonadIO m => BufferMEF-> (Addr# -> m a) -> m a #-}-withBufferAddr# = unsafeWithBufferAddr#---- | Do something with a buffer pointer-withBufferPtr :: MonadIO m => Buffer 'Mutable 'Pinned fin heap -> (Ptr b -> m a) -> m a-{-# INLINABLE withBufferPtr #-}-{-# SPECIALIZE INLINE withBufferPtr :: MonadIO m => BufferMP -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferPtr :: MonadIO m => BufferME -> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferPtr :: MonadIO m => BufferMPF-> (Ptr b -> m a) -> m a #-}-{-# SPECIALIZE INLINE withBufferPtr :: MonadIO m => BufferMEF-> (Ptr b -> m a) -> m a #-}-withBufferPtr = unsafeWithBufferPtr---- | Get buffer size-bufferSizeIO :: MonadIO m => Buffer mut pin fin heap -> m Word-{-# INLINABLE bufferSizeIO #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferI -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferP -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferM -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferMP -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferME -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferE -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferF -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferPF -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferMF -> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferMPF-> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferMEF-> m Word #-}-{-# SPECIALIZE INLINE bufferSizeIO :: MonadIO m => BufferEF -> m Word #-}-bufferSizeIO = \case- BufferM ba -> bufferSizeMBA ba- BufferMP ba -> bufferSizeMBA ba- BufferMF ba _fin -> bufferSizeMBA ba- BufferMPF ba _fin -> bufferSizeMBA ba- BufferME _addr sz -> return sz- BufferMEF _addr sz _fin -> return sz- BufferE _addr sz -> return sz- BufferEF _addr sz _fin -> return sz- Buffer ba -> pure $ bufferSizeBA ba- BufferP ba -> pure $ bufferSizeBA ba- BufferF ba _fin -> pure $ bufferSizeBA ba- BufferPF ba _fin -> pure $ bufferSizeBA ba--bufferSizeMBA :: MonadIO m => MutableByteArray# RealWorld -> m Word-bufferSizeMBA mba = liftIO $ IO \s -> case getSizeofMutableByteArray# mba s of- (# s', i #) -> case int2Word# i of- n -> (# s', W# n #)--bufferSizeBA :: ByteArray# -> Word-bufferSizeBA ba = W# (int2Word# (sizeofByteArray# ba))--class BufferSize a where- -- | Get buffer size- bufferSize :: a -> Word--instance BufferSize BufferI where- {-# INLINABLE bufferSize #-}- bufferSize (Buffer ba) = bufferSizeBA ba-instance BufferSize BufferP where- {-# INLINABLE bufferSize #-}- bufferSize (BufferP ba) = bufferSizeBA ba-instance BufferSize BufferF where- {-# INLINABLE bufferSize #-}- bufferSize (BufferF ba _fin) = bufferSizeBA ba-instance BufferSize BufferPF where- {-# INLINABLE bufferSize #-}- bufferSize (BufferPF ba _fin) = bufferSizeBA ba-instance BufferSize BufferME where- {-# INLINABLE bufferSize #-}- bufferSize (BufferME _addr sz) = sz-instance BufferSize BufferMEF where- {-# INLINABLE bufferSize #-}- bufferSize (BufferMEF _addr sz _fin) = sz-instance BufferSize BufferE where- {-# INLINABLE bufferSize #-}- bufferSize (BufferE _addr sz) = sz-instance BufferSize BufferEF where- {-# INLINABLE bufferSize #-}- bufferSize (BufferEF _addr sz _fin) = sz---- | Get contents as a list of bytes-bufferToListIO :: MonadIO m => Buffer mut pin fin heap -> m [Word8]-bufferToListIO b = case b of- Buffer _ba -> pure (toListBuffer b)- BufferP _ba -> pure (toListBuffer b)- BufferF _ba _fin -> pure (toListBuffer b)- BufferPF _ba _fin -> pure (toListBuffer b)- BufferM _ba -> toListBufferIO b- BufferMP _ba -> toListBufferIO b- BufferMF _ba _fin -> toListBufferIO b- BufferMPF _ba _fin -> toListBufferIO b- BufferME addr sz -> peekArray sz (Ptr addr)- BufferMEF addr sz _fin -> peekArray sz (Ptr addr)- BufferE addr sz -> peekArray sz (Ptr addr)- BufferEF addr sz _fin -> peekArray sz (Ptr addr)---- | Convert a buffer into a list of bytes by reading bytes one by one-toListBufferIO :: MonadIO m => Buffer mut pin fin heap -> m [Word8]-toListBufferIO b = do- sz <- bufferSizeIO b- let- go i xs = do- x <- bufferReadWord8IO b i- if i == 0- then return (x:xs)- else go (i-1) (x:xs)- go (sz-1) []---- | Convert a buffer into a list of bytes by reading bytes one by one-toListBuffer :: BufferSize (Buffer 'Immutable pin fin heap) => Buffer 'Immutable pin fin heap -> [Word8]-toListBuffer b = if sz == 0 then [] else fmap (bufferReadWord8 b) [0..(sz-1)] - where- sz = bufferSize b--class BufferToList a where- -- | Get contents as a list of bytes- bufferToList :: a -> [Word8]--instance BufferToList BufferI where- bufferToList b = toListBuffer b-instance BufferToList BufferP where- bufferToList b = toListBuffer b-instance BufferToList BufferF where- bufferToList b = toListBuffer b-instance BufferToList BufferPF where- bufferToList b = toListBuffer b---- | Support for OverloadedLists------ >>> :set -XOverloadedLists--- >>> let b = [25,26,27,28] :: BufferI----instance IsList BufferI where- type Item BufferI = Word8- toList b = toListBuffer b- fromList xs = unsafePerformIO do- let sz = fromIntegral (length xs)- b <- newBuffer sz- forM_ ([0..] `zip` xs) \(i,x) -> do- bufferWriteWord8IO b i x- unsafeBufferFreeze b-- fromListN sz xs = unsafePerformIO do- b <- newBuffer (fromIntegral sz)- forM_ ([0..] `zip` xs) \(i,x) -> do- bufferWriteWord8IO b i x- unsafeBufferFreeze b----- | Read a Word8, offset in bytes------ We don't check that the offset is valid------ >>> let b = [25,26,27,28] :: BufferI--- >>> bufferReadWord8IO b 2 --- 27----bufferReadWord8IO :: MonadIO m => Buffer mut pin fin heap -> Word -> m Word8-{-# INLINABLE bufferReadWord8IO #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferI -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferP -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferM -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferMP -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferME -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferE -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferF -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferPF -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferMF -> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferMPF-> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferMEF-> Word -> m Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8IO :: MonadIO m => BufferEF -> Word -> m Word8 #-}-bufferReadWord8IO b (fromIntegral -> !(I# off)) = case b of- BufferM ba -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferMP ba -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferMF ba _fin -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8Array# ba off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferME addr _sz -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferE addr _sz -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #)- BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord8OffAddr# addr off s of (# s2 , r #) -> (# s2 , W8# r #)- Buffer ba -> return (W8# (indexWord8Array# ba off))- BufferP ba -> return (W8# (indexWord8Array# ba off))- BufferF ba _fin -> return (W8# (indexWord8Array# ba off))- BufferPF ba _fin -> return (W8# (indexWord8Array# ba off))---- | Read a Word8 in an immutable buffer, offset in bytes------ We don't check that the offset is valid------ >>> let b = [25,26,27,28] :: BufferI--- >>> putStrLn $ "Word8 at offset 2 is " ++ show (bufferReadWord8 b 2)--- Word8 at offset 2 is 27----bufferReadWord8 :: Buffer 'Immutable pin fin heap -> Word -> Word8-{-# INLINABLE bufferReadWord8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferI -> Word -> Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferP -> Word -> Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferE -> Word -> Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferF -> Word -> Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferPF -> Word -> Word8 #-}-{-# SPECIALIZE INLINE bufferReadWord8 :: BufferEF -> Word -> Word8 #-}-bufferReadWord8 b (fromIntegral -> !(I# off)) = case b of- Buffer ba -> W8# (indexWord8Array# ba off)- BufferP ba -> W8# (indexWord8Array# ba off)- BufferF ba _fin -> W8# (indexWord8Array# ba off)- BufferPF ba _fin -> W8# (indexWord8Array# ba off)- BufferE addr _sz -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#)- BufferEF addr _sz _fin -> W8# (indexWord8OffAddr# (addr `plusAddr#` off) 0#)---- | Write a Word8, offset in bytes------ We don't check that the offset is valid------ >>> b <- newBuffer 10--- >>> bufferWriteWord8IO b 1 123--- >>> bufferReadWord8IO b 1 --- 123----bufferWriteWord8IO :: MonadIO m => Buffer 'Mutable pin fin heap -> Word -> Word8 -> m ()-{-# INLINABLE bufferWriteWord8IO #-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferM -> Word -> Word8 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMP -> Word -> Word8 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferME -> Word -> Word8 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMF -> Word -> Word8 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMPF-> Word -> Word8 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord8IO :: MonadIO m => BufferMEF-> Word -> Word8 -> m ()#-}-bufferWriteWord8IO b (fromIntegral -> !(I# off)) (W8# v) = case b of- BufferM ba -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #)- BufferMP ba -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #)- BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #)- BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8Array# ba off v s of s2 -> (# s2 , () #)- BufferME addr _sz -> liftIO $ IO \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord8OffAddr# addr off v s of s2 -> (# s2 , () #)----- | Read a Word16, offset in bytes------ We don't check that the offset is valid------ >>> let b = [0x12,0x34,0x56,0x78] :: BufferI--- >>> x <- bufferReadWord16IO b 0--- >>> (x == 0x1234) || (x == 0x3412)--- True----bufferReadWord16IO :: MonadIO m => Buffer mut pin fin heap -> Word -> m Word16-{-# INLINABLE bufferReadWord16IO #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferI -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferP -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferM -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferMP -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferME -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferE -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferF -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferPF -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferMF -> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferMPF-> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferMEF-> Word -> m Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16IO :: MonadIO m => BufferEF -> Word -> m Word16 #-}-bufferReadWord16IO b (fromIntegral -> !(I# off)) = case b of- BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #)- BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #)- BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #)- BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord16# ba off s of (# s2 , r #) -> (# s2 , W16# r #)- BufferME addr _sz -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #)- BufferE addr _sz -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #)- BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord16OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W16# r #)- Buffer ba -> return (W16# (indexWord8ArrayAsWord16# ba off))- BufferP ba -> return (W16# (indexWord8ArrayAsWord16# ba off))- BufferF ba _fin -> return (W16# (indexWord8ArrayAsWord16# ba off))- BufferPF ba _fin -> return (W16# (indexWord8ArrayAsWord16# ba off))---- | Read a Word16 in an immutable buffer, offset in bytes------ We don't check that the offset is valid-bufferReadWord16 :: Buffer 'Immutable pin fin heap -> Word -> Word16-{-# INLINABLE bufferReadWord16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferI -> Word -> Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferP -> Word -> Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferE -> Word -> Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferF -> Word -> Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferPF -> Word -> Word16 #-}-{-# SPECIALIZE INLINE bufferReadWord16 :: BufferEF -> Word -> Word16 #-}-bufferReadWord16 b (fromIntegral -> !(I# off)) = case b of- Buffer ba -> W16# (indexWord8ArrayAsWord16# ba off)- BufferP ba -> W16# (indexWord8ArrayAsWord16# ba off)- BufferF ba _fin -> W16# (indexWord8ArrayAsWord16# ba off)- BufferPF ba _fin -> W16# (indexWord8ArrayAsWord16# ba off)- BufferE addr _sz -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#)- BufferEF addr _sz _fin -> W16# (indexWord16OffAddr# (addr `plusAddr#` off) 0#)---- | Write a Word16, offset in bytes------ We don't check that the offset is valid------ >>> b <- newBuffer 10--- >>> let v = 1234 :: Word16--- >>> bufferWriteWord16IO b 1 v--- >>> bufferReadWord16IO b 1--- 1234------ >>> (x :: Word16) <- fromIntegral <$> bufferReadWord8IO b 1--- >>> (y :: Word16) <- fromIntegral <$> bufferReadWord8IO b 2--- >>> (((x `shiftL` 8) .|. y) == v) || (((y `shiftL` 8) .|. x) == v)--- True----bufferWriteWord16IO :: MonadIO m => Buffer 'Mutable pin fin heap -> Word -> Word16 -> m ()-{-# INLINABLE bufferWriteWord16IO #-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferM -> Word -> Word16 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMP -> Word -> Word16 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferME -> Word -> Word16 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMF -> Word -> Word16 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMPF-> Word -> Word16 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord16IO :: MonadIO m => BufferMEF-> Word -> Word16 -> m ()#-}-bufferWriteWord16IO b (fromIntegral -> !(I# off)) (W16# v) = case b of- BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #)- BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #)- BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #)- BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord16# ba off v s of s2 -> (# s2 , () #)- BufferME addr _sz -> liftIO $ IO \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord16OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)------ | Read a Word32, offset in bytes------ We don't check that the offset is valid------ >>> let b = [0x12,0x34,0x56,0x78] :: BufferI--- >>> x <- bufferReadWord32IO b 0--- >>> (x == 0x12345678) || (x == 0x78563412)--- True----bufferReadWord32IO :: MonadIO m => Buffer mut pin fin heap -> Word -> m Word32-{-# INLINABLE bufferReadWord32IO #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferI -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferP -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferM -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferMP -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferME -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferE -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferF -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferPF -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferMF -> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferMPF-> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferMEF-> Word -> m Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32IO :: MonadIO m => BufferEF -> Word -> m Word32 #-}-bufferReadWord32IO b (fromIntegral -> !(I# off)) = case b of- BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #)- BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #)- BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #)- BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord32# ba off s of (# s2 , r #) -> (# s2 , W32# r #)- BufferME addr _sz -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #)- BufferE addr _sz -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #)- BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord32OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W32# r #)- Buffer ba -> return (W32# (indexWord8ArrayAsWord32# ba off))- BufferP ba -> return (W32# (indexWord8ArrayAsWord32# ba off))- BufferF ba _fin -> return (W32# (indexWord8ArrayAsWord32# ba off))- BufferPF ba _fin -> return (W32# (indexWord8ArrayAsWord32# ba off))---- | Read a Word32 in an immutable buffer, offset in bytes------ We don't check that the offset is valid-bufferReadWord32 :: Buffer 'Immutable pin fin heap -> Word -> Word32-{-# INLINABLE bufferReadWord32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferI -> Word -> Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferP -> Word -> Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferE -> Word -> Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferF -> Word -> Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferPF -> Word -> Word32 #-}-{-# SPECIALIZE INLINE bufferReadWord32 :: BufferEF -> Word -> Word32 #-}-bufferReadWord32 b (fromIntegral -> !(I# off)) = case b of- Buffer ba -> W32# (indexWord8ArrayAsWord32# ba off)- BufferP ba -> W32# (indexWord8ArrayAsWord32# ba off)- BufferF ba _fin -> W32# (indexWord8ArrayAsWord32# ba off)- BufferPF ba _fin -> W32# (indexWord8ArrayAsWord32# ba off)- BufferE addr _sz -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#)- BufferEF addr _sz _fin -> W32# (indexWord32OffAddr# (addr `plusAddr#` off) 0#)---- | Write a Word32, offset in bytes------ We don't check that the offset is valid------ >>> b <- newBuffer 10--- >>> let v = 1234 :: Word32--- >>> bufferWriteWord32IO b 1 v--- >>> bufferReadWord32IO b 1--- 1234----bufferWriteWord32IO :: MonadIO m => Buffer 'Mutable pin fin heap -> Word -> Word32 -> m ()-{-# INLINABLE bufferWriteWord32IO #-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferM -> Word -> Word32 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMP -> Word -> Word32 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferME -> Word -> Word32 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMF -> Word -> Word32 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMPF-> Word -> Word32 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord32IO :: MonadIO m => BufferMEF-> Word -> Word32 -> m ()#-}-bufferWriteWord32IO b (fromIntegral -> !(I# off)) (W32# v) = case b of- BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #)- BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #)- BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #)- BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord32# ba off v s of s2 -> (# s2 , () #)- BufferME addr _sz -> liftIO $ IO \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord32OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)----- | Read a Word64, offset in bytes------ We don't check that the offset is valid------ >>> let b = [0x12,0x34,0x56,0x78,0x9A,0xBC,0xDE,0xF0] :: BufferI--- >>> x <- bufferReadWord64IO b 0--- >>> (x == 0x123456789ABCDEF0) || (x == 0xF0DEBC9A78563412)--- True----bufferReadWord64IO :: MonadIO m => Buffer mut pin fin heap -> Word -> m Word64-{-# INLINABLE bufferReadWord64IO #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferI -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferP -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferM -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferMP -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferME -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferE -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferF -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferPF -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferMF -> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferMPF-> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferMEF-> Word -> m Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64IO :: MonadIO m => BufferEF -> Word -> m Word64 #-}-bufferReadWord64IO b (fromIntegral -> !(I# off)) = case b of- BufferM ba -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #)- BufferMP ba -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #)- BufferMF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #)- BufferMPF ba _fin -> liftIO $ IO \s -> case readWord8ArrayAsWord64# ba off s of (# s2 , r #) -> (# s2 , W64# r #)- BufferME addr _sz -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #)- BufferE addr _sz -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #)- BufferEF addr _sz _fin -> liftIO $ IO \s -> case readWord64OffAddr# (addr `plusAddr#` off) 0# s of (# s2 , r #) -> (# s2 , W64# r #)- Buffer ba -> return (W64# (indexWord8ArrayAsWord64# ba off))- BufferP ba -> return (W64# (indexWord8ArrayAsWord64# ba off))- BufferF ba _fin -> return (W64# (indexWord8ArrayAsWord64# ba off))- BufferPF ba _fin -> return (W64# (indexWord8ArrayAsWord64# ba off))---- | Read a Word64 in an immutable buffer, offset in bytes------ We don't check that the offset is valid-bufferReadWord64 :: Buffer 'Immutable pin fin heap -> Word -> Word64-{-# INLINABLE bufferReadWord64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferI -> Word -> Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferP -> Word -> Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferE -> Word -> Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferF -> Word -> Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferPF -> Word -> Word64 #-}-{-# SPECIALIZE INLINE bufferReadWord64 :: BufferEF -> Word -> Word64 #-}-bufferReadWord64 b (fromIntegral -> !(I# off)) = case b of- Buffer ba -> W64# (indexWord8ArrayAsWord64# ba off)- BufferP ba -> W64# (indexWord8ArrayAsWord64# ba off)- BufferF ba _fin -> W64# (indexWord8ArrayAsWord64# ba off)- BufferPF ba _fin -> W64# (indexWord8ArrayAsWord64# ba off)- BufferE addr _sz -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#)- BufferEF addr _sz _fin -> W64# (indexWord64OffAddr# (addr `plusAddr#` off) 0#)---- | Write a Word64, offset in bytes------ We don't check that the offset is valid------ >>> b <- newBuffer 10--- >>> let v = 1234 :: Word64--- >>> bufferWriteWord64IO b 1 v--- >>> bufferReadWord64IO b 1--- 1234----bufferWriteWord64IO :: MonadIO m => Buffer 'Mutable pin fin heap -> Word -> Word64 -> m ()-{-# INLINABLE bufferWriteWord64IO #-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferM -> Word -> Word64 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMP -> Word -> Word64 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferME -> Word -> Word64 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMF -> Word -> Word64 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMPF-> Word -> Word64 -> m ()#-}-{-# SPECIALIZE INLINE bufferWriteWord64IO :: MonadIO m => BufferMEF-> Word -> Word64 -> m ()#-}-bufferWriteWord64IO b (fromIntegral -> !(I# off)) (W64# v) = case b of- BufferM ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #)- BufferMP ba -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #)- BufferMF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #)- BufferMPF ba _fin -> liftIO $ IO \s -> case writeWord8ArrayAsWord64# ba off v s of s2 -> (# s2 , () #)- BufferME addr _sz -> liftIO $ IO \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)- BufferMEF addr _sz _fin -> liftIO $ IO \s -> case writeWord64OffAddr# (addr `plusAddr#` off) 0# v s of s2 -> (# s2 , () #)----- | Copy a buffer into another from/to the given offsets------ We don't check buffer limits.------ >>> let b = [0,1,2,3,4,5,6,7,8] :: BufferI--- >>> b2 <- newBuffer 8--- >>> copyBuffer b 4 b2 0 4--- >>> copyBuffer b 0 b2 4 4--- >>> forM [0..7] (bufferReadWord8IO b2)--- [4,5,6,7,0,1,2,3]----copyBuffer :: forall m mut pin0 fin0 heap0 pin1 fin1 heap1.- MonadIO m- => Buffer mut pin0 fin0 heap0 -- ^ Source buffer- -> Word -- ^ Offset in source buffer- -> Buffer 'Mutable pin1 fin1 heap1 -- ^ Target buffer- -> Word -- ^ Offset in target buffer- -> Word -- ^ Number of Word8 to copy- -> m ()-{-# INLINABLE copyBuffer #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferI -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferP -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferM -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMP -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferME -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferE -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferF -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferPF -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMF -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMPF -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferMEF -> Word -> BufferMEF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferM -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferMP -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferME -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferMF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferMPF -> Word -> Word -> m () #-}-{-# SPECIALIZE INLINE copyBuffer :: MonadIO m => BufferEF -> Word -> BufferMEF -> Word -> Word -> m () #-}-copyBuffer sb (fromIntegral -> I# soff) db (fromIntegral -> I# doff) (fromIntegral -> I# cnt) = buf2buf- where- buf2buf = case db of- BufferM mba -> toMba mba- BufferMP mba -> toMba mba- BufferMF mba _f -> toMba mba- BufferMPF mba _f -> toMba mba- BufferME addr _sz -> toAddr addr- BufferMEF addr _sz _f -> toAddr addr-- toMba :: MutableByteArray# RealWorld -> m ()- toMba mba = case sb of- Buffer ba -> baToMba ba mba- BufferP ba -> baToMba ba mba- BufferM mba2 -> mbaToMba mba2 mba- BufferMP mba2 -> mbaToMba mba2 mba- BufferME addr _sz -> addrToMba addr mba- BufferE addr _sz -> addrToMba addr mba- BufferF ba _f -> baToMba ba mba- BufferPF ba _f -> baToMba ba mba- BufferMF mba2 _f -> mbaToMba mba2 mba- BufferMPF mba2 _f -> mbaToMba mba2 mba- BufferMEF addr _sz _f -> addrToMba addr mba- BufferEF addr _sz _f -> addrToMba addr mba-- toAddr :: Addr# -> m ()- toAddr addr = case sb of- Buffer ba -> baToAddr ba addr- BufferP ba -> baToAddr ba addr- BufferM mba -> mbaToAddr mba addr- BufferMP mba -> mbaToAddr mba addr- BufferME addr2 _sz -> addrToAddr addr2 addr- BufferE addr2 _sz -> addrToAddr addr2 addr- BufferF ba _f -> baToAddr ba addr- BufferPF ba _f -> baToAddr ba addr- BufferMF mba _f -> mbaToAddr mba addr- BufferMPF mba _f -> mbaToAddr mba addr- BufferMEF addr2 _sz _f -> addrToAddr addr2 addr- BufferEF addr2 _sz _f -> addrToAddr addr2 addr-- mbaToMba :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> m ()- mbaToMba mba1 mba2 =- liftIO $ IO \s ->- case copyMutableByteArray# mba1 soff mba2 doff cnt s of- s2 -> (# s2, () #)-- baToMba :: ByteArray# -> MutableByteArray# RealWorld -> m ()- baToMba ba mba =- liftIO $ IO \s ->- case copyByteArray# ba soff mba doff cnt s of- s2 -> (# s2, () #)-- addrToMba :: Addr# -> MutableByteArray# RealWorld -> m ()- addrToMba addr mba =- liftIO $ IO \s ->- case copyAddrToByteArray# (addr `plusAddr#` soff) mba doff cnt s of- s2 -> (# s2, () #)-- baToAddr :: ByteArray# -> Addr# -> m ()- baToAddr ba addr =- liftIO $ IO \s ->- case copyByteArrayToAddr# ba soff (addr `plusAddr#` doff) cnt s of- s2 -> (# s2, () #)--- mbaToAddr :: MutableByteArray# RealWorld -> Addr# -> m ()- mbaToAddr mba addr =- liftIO $ IO $ \s ->- case copyMutableByteArrayToAddr# mba soff (addr `plusAddr#` doff) cnt s of- s2 -> (# s2, () #)-- addrToAddr :: Addr# -> Addr# -> m ()- addrToAddr addr1 addr2 =- liftIO $ memcpy# (addr1 `plusAddr#` soff)- (addr2 `plusAddr#` doff)- cnt- --------------------------------------------------------------------- AnyBuffer---------------------------------------------------------------------- | Wrapper containing any kind of buffer-newtype AnyBuffer = AnyBuffer (forall mut pin fin heap. Buffer mut pin fin heap)+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}++-- | A buffer in memory+module Haskus.Memory.Buffer where++import Haskus.Number.Word+import Haskus.Number.Int+import Haskus.Binary.Storable+import Haskus.Memory.Utils (memcpy#)+import Haskus.Utils.Monad++import Data.IORef+import System.IO.Unsafe+#if MIN_VERSION_GLASGOW_HASKELL (9,0,0,0)+import Unsafe.Coerce (unsafeCoerce#)+#endif++import GHC.STRef+import GHC.IORef+import GHC.Prim+import GHC.Base+import GHC.Exts (toList, IsList(..), Ptr (..))++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeApplications+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeFamilies+-- >>> :set -XScopedTypeVariables+-- >>> import Haskus.Binary.Bits++-- There are different kinds of buffers:+-- 1. in managed heap: small and unpinned+-- 2. in managed heap: pinned+-- 3. out of the managed heap+--+-- GHC maintains a distinction between immutable and mutable in heap buffers+-- (respectively ByteArray# and MutableByteArray#) but they are represented by+-- the same heap objects and we can freely convert from one to the other.+--+-- Buffers and managed heap may be pinned (i.e. may have a fixed address). GHC+-- automatically pins large buffers. Buffers out of the managed heap are+-- represented by their address, hence the latter mustn't/can't change and they+-- behave as pinned buffers.+--+-- It is common to want to attach finalizers to buffers (e.g. to reclaim memory+-- for buffer out of the managed heap). We can't directly attach them to the+-- Addr# or to the ByteArray#. We must also be very careful to avoid attaching+-- them to the box (e.g. to "Ptr" in "Ptr Addr#") because GHC freely removes+-- boxes to produce faster code. The best option is to attach the finalizers to+-- an IORef which contains the finalizers themselves!+--+-- For performance, we often want buffer references to be unboxed. Hence the use+-- of unboxed sums/tuples.++type InBuffer# s = MutableByteArray# s+type ExtBuffer# = (# Addr#, Word# #)+type Finalizers# s = (# (# #) | MutVar# s [IO ()] #) -- Finalizers are optional+type Buffer# s = (# (# InBuffer# s | ExtBuffer# #), Finalizers# s #)++data STBuffer s = Buffer (Buffer# s)+type Buffer = STBuffer RealWorld++{-# COMPLETE InBuffer, OutBuffer #-}++pattern OutBuffer :: Addr# -> Word# -> Finalizers# s -> STBuffer s+pattern OutBuffer addr sz fin = Buffer (# (# | (# addr, sz #) #), fin #)++pattern InBuffer :: MutableByteArray# s -> Finalizers# s -> STBuffer s+pattern InBuffer ba fin = Buffer (# (# ba | #), fin #)++{-# COMPLETE NoFinalizers, Finalizers #-}++pattern NoFinalizers :: Finalizers# s+pattern NoFinalizers = (# (# #) | #)++pattern Finalizers :: MutVar# s [IO ()] -> Finalizers# s+pattern Finalizers fin = (# | fin #)+-----------------------------------------------------------------+-- Allocation+-----------------------------------------------------------------++-- | Allocate a buffer (unpinned if small)+--+-- >>> b <- newBuffer 1024+--+newBuffer :: Word -> IO Buffer+newBuffer (W# sz) = IO \s0 ->+ let !(# s1,ba #) = newByteArray# (word2Int# sz) s0+ in (# s1, InBuffer ba NoFinalizers #)+++-- | Allocate a buffer (pinned)+newPinnedBuffer :: Word -> IO Buffer+newPinnedBuffer (W# sz) = IO \s0 ->+ let !(# s1,ba #) = newPinnedByteArray# (word2Int# sz) s0+ in (# s1, InBuffer ba NoFinalizers #)++-- | Allocate an aligned buffer (pinned)+newAlignedPinnedBuffer :: Word -> Word -> IO Buffer+newAlignedPinnedBuffer (W# sz) (W# al) = IO \s0 ->+ let !(# s1,ba #) = newAlignedPinnedByteArray# (word2Int# sz) (word2Int# al) s0+ in (# s1, InBuffer ba NoFinalizers #)++-- | Attach an external buffer+attachExternalBuffer :: Addr# -> Word# -> Buffer+attachExternalBuffer addr sz = OutBuffer addr sz NoFinalizers++-- | Attach an external buffer+attachExternalBufferPtr :: Ptr a -> Word# -> Buffer+attachExternalBufferPtr (Ptr addr) sz = attachExternalBuffer addr sz++-- | Attach an external buffer with finalizers+attachFinalizedBuffer :: Addr# -> Word# -> IO Buffer+attachFinalizedBuffer addr sz = IO \s ->+ let !(# s', fin #) = newMutVar# [] s+ in (# s', OutBuffer addr sz (Finalizers fin) #)++-----------------------------------------------------------------+-- Finalizers+-----------------------------------------------------------------++getFinalizers :: STBuffer s -> Finalizers# s+getFinalizers = \case+ InBuffer _ fin -> fin+ OutBuffer _ _ fin -> fin++-- | Add a finalizer.+--+-- The latest added finalizers are executed first. Finalizers are not guaranteed+-- to run (e.g. if the program exits before the buffer is collected).+--+addFinalizer :: Buffer -> IO () -> IO ()+addFinalizer b f = do+ let !fin = getFinalizers b+ case fin of+ Finalizers rfs -> do+ mBox <- atomicModifyIORef (IORef (STRef rfs)) $ \finalizers -> case finalizers of+ [] -> let box = [f] in (box , Just box)+ fs -> (f:fs, Nothing)+ -- add the weak reference to the first cons cell of the finalizers list,+ -- that's the only boxed thing we have.+ case mBox of+ Nothing -> return ()+ Just box -> IO \s ->+ case mkWeak# box b (unIO $ runFinalizers fin) s of+ (# s1, _wk #) -> (# s1, () #) + NoFinalizers -> error "insertFinalizer: can't insert finalizer (NoFinalizers)" ++-- | Internal function used to execute finalizers+runFinalizers :: Finalizers# RealWorld -> IO ()+runFinalizers = \case+ NoFinalizers -> return ()+ Finalizers fin -> do+ -- atomically remove finalizers to avoid double execution+ fs <- atomicModifyIORef (IORef (STRef fin)) $ \fs -> ([], fs)+ sequence_ fs++-- | Indicate if a buffer is pinned+bufferIsPinned :: STBuffer s -> Bool+bufferIsPinned = \case+ OutBuffer {} -> True+ InBuffer ba _ -> isTrue# (isMutableByteArrayPinned# ba)++-- | Touch a buffer to keep it alive+bufferTouch :: Buffer -> IO ()+bufferTouch b = IO \s -> case getFinalizers b of+ NoFinalizers -> (# s, () #)+ Finalizers fin -> case touch# fin s of+ s' -> (# s', () #)++withBuffer :: Buffer -> IO a -> IO a+withBuffer b f = do+ r <- f+ bufferTouch b+ pure r++-- | Get buffer size+bufferSize :: Buffer -> IO Word+bufferSize = \case+ OutBuffer _addr sz _fin -> pure (W# sz)+ InBuffer ba _fin -> IO \s -> case getSizeofMutableByteArray# ba s of+ (# s', i #) -> (# s', W# (int2Word# i) #)++-- | Buffer address (careful with unpinned buffers!)+bufferAddr# :: Buffer -> Addr#+bufferAddr# = \case+ OutBuffer addr _ _ -> addr+ InBuffer ba _ -> byteArrayContents# (unsafeCoerce# ba)++-- | Get contents as a list of bytes+bufferToList :: Buffer -> IO [Word8]+bufferToList b = withBuffer b case b of+ OutBuffer addr sz _fin -> peekArray (W# sz) (Ptr addr)+ InBuffer {}+ | bufferIsPinned b -> do+ sz <- bufferSize b+ peekArray sz (Ptr (bufferAddr# b))++ InBuffer {} -> do+ sz <- bufferSize b+ let+ go i xs = do+ x <- bufferReadWord8 b i+ if i == 0+ then pure (x:xs)+ else go (i-1) (x:xs)+ go (sz-1) []++-- | Read a Word8, offset in bytes+--+-- We don't check that the offset is valid+bufferReadWord8 :: Buffer -> Word -> IO Word8+bufferReadWord8 b (W# off) = withBuffer b case b of+ InBuffer ba _fin -> IO \s -> case readWord8Array# ba (word2Int# off) s of+ (# s2 , r #) -> (# s2 , W8# r #)++ OutBuffer addr _sz _fin -> IO \s -> case readWord8OffAddr# addr (word2Int# off) s of+ (# s2 , r #) -> (# s2 , W8# r #)++-- | Read a Word16, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> let b = [0x12,0x34,0x56,0x78] :: Buffer+-- >>> x <- bufferReadWord16IO b 0+-- >>> (x == 0x1234) || (x == 0x3412)+-- True+--+bufferReadWord16 :: Buffer -> Word -> IO Word16+bufferReadWord16 b (W# off) = withBuffer b case b of+ InBuffer ba _fin -> IO \s -> case readWord8ArrayAsWord16# ba (word2Int# off) s of+ (# s2 , r #) -> (# s2 , W16# r #)++ OutBuffer addr _sz _fin -> IO \s -> case readWord16OffAddr# (addr `plusAddr#` word2Int# off) 0# s of+ (# s2 , r #) -> (# s2 , W16# r #)+++-- | Read a Word32, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> let b = [0x12,0x34,0x56,0x78] :: Buffer+-- >>> x <- bufferReadWord32IO b 0+-- >>> (x == 0x12345678) || (x == 0x78563412)+-- True+--+bufferReadWord32 :: Buffer -> Word -> IO Word32+bufferReadWord32 b (W# off) = withBuffer b case b of+ InBuffer ba _fin -> IO \s -> case readWord8ArrayAsWord32# ba (word2Int# off) s of+ (# s2 , r #) -> (# s2 , W32# r #)++ OutBuffer addr _sz _fin -> IO \s -> case readWord32OffAddr# (addr `plusAddr#` word2Int# off) 0# s of+ (# s2 , r #) -> (# s2 , W32# r #)++-- | Read a Word64, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> let b = [0x12,0x34,0x56,0x78,0x9A,0xBC,0xDE,0xF0] :: Buffer+-- >>> x <- bufferReadWord64IO b 0+-- >>> (x == 0x123456789ABCDEF0) || (x == 0xF0DEBC9A78563412)+-- True+--+bufferReadWord64 :: Buffer -> Word -> IO Word64+bufferReadWord64 b (W# off) = withBuffer b case b of+ InBuffer ba _fin -> IO \s -> case readWord8ArrayAsWord64# ba (word2Int# off) s of+ (# s2 , r #) -> (# s2 , W64# r #)++ OutBuffer addr _sz _fin -> IO \s -> case readWord64OffAddr# (addr `plusAddr#` word2Int# off) 0# s of+ (# s2 , r #) -> (# s2 , W64# r #)++-- | Do something with a buffer address+--+-- Note: don't write into immutable buffers as it would break referential+-- consistency+withBufferAddr# :: Buffer -> (Addr# -> IO a) -> IO a+withBufferAddr# b f = withBuffer b (f (bufferAddr# b))++-- | Write a Word8, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> b <- newBuffer 10+-- >>> bufferWriteWord8IO b 1 123+-- >>> bufferReadWord8IO b 1 +-- 123+--+bufferWriteWord8 :: Buffer -> Word -> Word8 -> IO ()+bufferWriteWord8 b (W# off) (W8# v) = withBuffer b case b of+ InBuffer ba _ -> IO \s -> case writeWord8Array# ba (word2Int# off) v s of s2 -> (# s2 , () #)+ OutBuffer addr _ _ -> IO \s -> case writeWord8OffAddr# addr (word2Int# off) v s of s2 -> (# s2 , () #)++-- | Write a Word16, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> b <- newBuffer 10+-- >>> let v = 1234 :: Word16+-- >>> bufferWriteWord16IO b 1 v+-- >>> bufferReadWord16IO b 1+-- 1234+--+-- >>> (x :: Word16) <- fromIntegral <$> bufferReadWord8IO b 1+-- >>> (y :: Word16) <- fromIntegral <$> bufferReadWord8IO b 2+-- >>> (((x `shiftL` 8) .|. y) == v) || (((y `shiftL` 8) .|. x) == v)+-- True+--+bufferWriteWord16 :: Buffer -> Word -> Word16 -> IO ()+bufferWriteWord16 b (W# off) (W16# v) = withBuffer b case b of+ InBuffer ba _ -> IO \s -> case writeWord8ArrayAsWord16# ba (word2Int# off) v s of s2 -> (# s2 , () #)+ OutBuffer addr _ _ -> IO \s -> case writeWord16OffAddr# (addr `plusAddr#` word2Int# off) 0# v s of s2 -> (# s2 , () #)++-- | Write a Word32, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> b <- newBuffer 10+-- >>> let v = 1234 :: Word32+-- >>> bufferWriteWord32IO b 1 v+-- >>> bufferReadWord32IO b 1+-- 1234+--+bufferWriteWord32 :: Buffer -> Word -> Word32 -> IO ()+bufferWriteWord32 b (W# off) (W32# v) = withBuffer b case b of+ InBuffer ba _ -> IO \s -> case writeWord8ArrayAsWord32# ba (word2Int# off) v s of s2 -> (# s2 , () #)+ OutBuffer addr _ _ -> IO \s -> case writeWord32OffAddr# (addr `plusAddr#` word2Int# off) 0# v s of s2 -> (# s2 , () #)+++-- | Write a Word64, offset in bytes+--+-- We don't check that the offset is valid+--+-- >>> b <- newBuffer 10+-- >>> let v = 1234 :: Word64+-- >>> bufferWriteWord64IO b 1 v+-- >>> bufferReadWord64IO b 1+-- 1234+--+bufferWriteWord64 :: Buffer -> Word -> Word64 -> IO ()+bufferWriteWord64 b (W# off) (W64# v) = withBuffer b case b of+ InBuffer ba _ -> IO \s -> case writeWord8ArrayAsWord64# ba (word2Int# off) v s of s2 -> (# s2 , () #)+ OutBuffer addr _ _ -> IO \s -> case writeWord64OffAddr# (addr `plusAddr#` word2Int# off) 0# v s of s2 -> (# s2 , () #)++++-- | Support for OverloadedLists+--+-- >>> :set -XOverloadedLists+-- >>> let b = [25,26,27,28] :: Buffer+--+instance IsList Buffer where+ type Item Buffer = Word8+ toList b = unsafePerformIO (bufferToList b)+ fromList xs = unsafePerformIO do+ let sz = fromIntegral (length xs)+ b <- newBuffer sz+ forM_ ([0..] `zip` xs) \(i,x) -> do+ bufferWriteWord8 b i x+ pure b++ fromListN sz xs = unsafePerformIO do+ b <- newBuffer (fromIntegral sz)+ forM_ ([0..] `zip` xs) \(i,x) -> do+ bufferWriteWord8 b i x+ pure b++-- | Copy a buffer into another from/to the given offsets+--+-- We don't check buffer limits.+--+-- >>> let b = [0,1,2,3,4,5,6,7,8] :: Buffer+-- >>> b2 <- newBuffer 8+-- >>> bufferCopy b 4 b2 0 4+-- >>> bufferCopy b 0 b2 4 4+-- >>> forM [0..7] (bufferReadWord8 b2)+-- [4,5,6,7,0,1,2,3]+--+bufferCopy+ :: Buffer -- ^ Source buffer+ -> Word -- ^ Offset in source buffer+ -> Buffer -- ^ Target buffer+ -> Word -- ^ Offset in target buffer+ -> Word -- ^ Number of Word8 to copy+ -> IO ()+bufferCopy src (W# soff) dst (W# doff) (W# cnt) = withBuffer src $ withBuffer dst case (src,dst) of+ (InBuffer sba _, InBuffer dba _) -> IO \s ->+ case copyMutableByteArray# sba (word2Int# soff) dba (word2Int# doff) (word2Int# cnt) s of+ s2 -> (# s2, () #)+ (InBuffer sba _, OutBuffer addr _ _) -> IO \s ->+ case copyMutableByteArrayToAddr# sba (word2Int# soff) (addr `plusAddr#` word2Int# doff) (word2Int# cnt) s of+ s2 -> (# s2, () #)+ (OutBuffer addr _ _, InBuffer dba _) -> IO \s ->+ case copyAddrToByteArray# (addr `plusAddr#` word2Int# soff) dba (word2Int# doff) (word2Int# cnt) s of+ s2 -> (# s2, () #)+ (OutBuffer addr1 _ _, OutBuffer addr2 _ _) ->+ memcpy# (addr1 `plusAddr#` word2Int# soff) (addr2 `plusAddr#` word2Int# doff) (word2Int# cnt)
src/lib/Haskus/Memory/Embed.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE BlockArguments #-} -- | Embed buffers into the program module Haskus.Memory.Embed@@ -14,10 +15,6 @@ , embedUnpinnedBuffer , loadSymbol , loadMutableSymbol- , toBufferE- , toBufferE'- , toBufferME- , toBufferME' , makeEmbeddingFile , EmbedEntry (..) , SectionType (..)@@ -43,10 +40,9 @@ -- >>> let b = $$(embedBytes [72,69,76,76,79]) -- >>> bufferSize b -- 5-embedBytes :: [Word8] -> Q (TExp BufferE)+embedBytes :: [Word8] -> Q Exp embedBytes bs = do- bufE <- fromMaybe (error "Please import Haskus.Memory.Embed") <$> lookupValueName "toBufferE'"- return $ TExp $ VarE bufE+ return $ VarE 'attachExternalBuffer `AppE` LitE (StringPrimL bs) `AppE` LitE (WordPrimL (fromIntegral (length bs))) @@ -64,12 +60,11 @@ loadSymbol :: Word -> String -> Q Exp loadSymbol sz sym = do nam <- newName sym- bufE <- fromMaybe (error "Please import Haskus.Memory.Embed") <$> lookupValueName "toBufferE" ptrTy <- [t| Ptr () |] addTopDecls [ ForeignD $ ImportF CCall unsafe ("&"++sym) nam ptrTy ]- return $ VarE bufE+ return $ VarE 'attachExternalBufferPtr `AppE` VarE nam `AppE` LitE (WordPrimL (fromIntegral sz)) @@ -94,33 +89,15 @@ loadMutableSymbol :: Word -> String -> Q Exp loadMutableSymbol sz sym = do nam <- newName sym- bufE <- fromMaybe (error "Please import Haskus.Memory.Embed") <$> lookupValueName "toBufferME" ptrTy <- [t| Ptr () |] addTopDecls [ ForeignD $ ImportF CCall unsafe ("&"++sym) nam ptrTy ]- return $ VarE bufE+ return $ VarE 'attachExternalBufferPtr `AppE` VarE nam `AppE` LitE (WordPrimL (fromIntegral sz)) -toBufferE :: Ptr () -> Word# -> BufferE-{-# INLINABLE toBufferE #-}-toBufferE (Ptr x) sz = BufferE x (W# sz)--toBufferE' :: Addr# -> Word# -> BufferE-{-# INLINABLE toBufferE' #-}-toBufferE' x sz = BufferE x (W# sz)--toBufferME :: Ptr () -> Word# -> BufferME-{-# INLINABLE toBufferME #-}-toBufferME (Ptr x) sz = BufferME x (W# sz)--toBufferME' :: Addr# -> Word# -> BufferME-{-# INLINABLE toBufferME' #-}-toBufferME' x sz = BufferME x (W# sz)-- -- | Section type data SectionType = ReadOnlySection -- ^ Read-only@@ -187,8 +164,7 @@ embedFile = embedFile' False --- | Embed a file in the executable. Return a BufferE or a BufferME depending on--- the mutability parameter.+-- | Embed a file in the executable. -- -- `nodep` parameter is used to indicate if we want to add a dependency on the -- input file (e.g. we don't want to do this for temporary files TH generated).@@ -228,7 +204,7 @@ -- | Embed a pinned buffer in the executable. Return either a BufferE or a -- BufferME. embedPinnedBuffer- :: Buffer mut 'Pinned fin heap -- ^ Source buffer+ :: Buffer -- ^ Source buffer -> Bool -- ^ Should the embedded buffer be mutable -> Maybe Word -- ^ Alignement -> Maybe Word -- ^ Offset in the buffer@@ -236,46 +212,42 @@ -> Q Exp -- ^ BufferE or BufferME, depending on mutability parameter embedPinnedBuffer buf mut malign moffset msize = do tmp <- qAddTempFile ".dat"- bsz <- bufferSizeIO buf+ bsz <- liftIO (bufferSize buf) let off = fromMaybe 0 moffset let sz = fromMaybe bsz msize when (off+sz > bsz) $ fail "Invalid buffer offset/size combination" - liftIO $ unsafeWithBufferPtr buf $ \ptr -> do+ liftIO $ withBufferAddr# buf \addr -> do withBinaryFile tmp WriteMode $ \hdl -> do- hPutBuf hdl (ptr `plusPtr` fromIntegral off) (fromIntegral sz)+ hPutBuf hdl (Ptr addr `plusPtr` fromIntegral off) (fromIntegral sz) embedFile' True tmp mut malign Nothing Nothing --- | Embed a unpinned buffer in the executable. Return either a BufferE or a--- BufferME.+-- | Embed a unpinned buffer in the executable. Return a Buffer. embedUnpinnedBuffer- :: Buffer mut 'NotPinned fin heap -- ^ Source buffer+ :: Buffer -- ^ Source buffer -> Bool -- ^ Should the embedded buffer be mutable -> Maybe Word -- ^ Alignement -> Maybe Word -- ^ Offset in the buffer -> Maybe Word -- ^ Number of Word8 to write -> Q Exp -- ^ BufferE or BufferME, depending on mutability parameter embedUnpinnedBuffer buf mut malign moffset msize = do- bsz <- liftIO (bufferSizeIO buf)+ bsz <- liftIO (bufferSize buf) let sz = fromMaybe bsz msize let off = fromMaybe 0 moffset- b <- newPinnedBuffer sz- liftIO (copyBuffer buf off b 0 sz)+ b <- liftIO (newPinnedBuffer sz)+ liftIO (bufferCopy buf off b 0 sz) embedPinnedBuffer b mut malign Nothing Nothing -- | Embed a buffer in the executable. Return either a BufferE or a BufferME. embedBuffer- :: Buffer mut pin fin heap -- ^ Source buffer+ :: Buffer -- ^ Source buffer -> Bool -- ^ Should the embedded buffer be mutable or not -> Maybe Word -- ^ Optional alignement constraint -> Maybe Word -- ^ Optional offset in the source buffer -> Maybe Word -- ^ Optional number of bytes to include -> Q Exp -- ^ BufferE or BufferME, depending on mutability parameter embedBuffer b =- -- Some buffers with 'NotPinned are in fact pinned by GHC as an optimization.- -- We detect this with `bufferDynamicallyPinned` and we avoid the copy in- -- these cases.- case bufferDynamicallyPinned b of- Left ub -> embedUnpinnedBuffer ub- Right pb -> embedPinnedBuffer pb+ if bufferIsPinned b+ then embedPinnedBuffer b+ else embedUnpinnedBuffer b
src/lib/Haskus/Memory/Typed.hs view
@@ -20,7 +20,7 @@ newtype PointerT (t :: k) mut fin = PointerT (Pointer mut fin) -- | Typed buffer-newtype BufferT (t :: k) mut pin fin heap = BufferT (Buffer mut pin fin heap)+newtype BufferT (t :: k) = BufferT Buffer -- | Typed raw pointer newtype PtrT (t :: k) = PtrT (Ptr ())
src/lib/Haskus/Memory/View.hs view
@@ -83,9 +83,9 @@ -- source. -- data ViewSource- = forall pin fin heap. SourceBuffer (Buffer 'Immutable pin fin heap)+ = SourceBuffer Buffer -- ^ The source is a buffer. The view keeps the buffer alive- | forall pin fin heap. SourceWeakBuffer (Weak (Buffer 'Immutable pin fin heap))+ | SourceWeakBuffer (Weak Buffer) -- ^ The source is a weak buffer. If the buffer is collected, its contents -- is copied in to a new buffer and the view is updated to use it. | SourceWeakView (Weak ViewIORef)@@ -151,12 +151,12 @@ _ -> PatternOn p1 p2 -- | Read a Word8 from a view-viewReadWord8 :: MonadIO m => View -> Word -> m Word8+viewReadWord8 :: View -> Word -> IO Word8 viewReadWord8 view off = withValidView view- (\b pat -> bufferReadWord8IO b (patternOffset pat off))- (\b pat -> bufferReadWord8IO b (patternOffset pat off))- (\v pat -> viewReadWord8 v (patternOffset pat off))+ (\b pat -> bufferReadWord8 b (patternOffset pat off))+ (\b pat -> bufferReadWord8 b (patternOffset pat off))+ (\v pat -> viewReadWord8 v (patternOffset pat off)) -- | Wait for a view to be valid then use one of the 3 passed functions on it@@ -164,8 +164,8 @@ withValidView :: MonadIO m => View- -> (forall pin fin heap. Buffer 'Immutable pin fin heap -> ViewPattern -> m a)- -> (forall pin fin heap. Buffer 'Immutable pin fin heap -> ViewPattern -> m a)+ -> (Buffer -> ViewPattern -> m a)+ -> (Buffer -> ViewPattern -> m a) -> (View -> ViewPattern -> m a) -> m a withValidView (View ref) fb fwb fwv = go True@@ -196,7 +196,7 @@ -- | Create a view on a buffer-newBufferView :: MonadIO m => Buffer 'Immutable pin fin heap -> ViewPattern -> m View+newBufferView :: MonadIO m => Buffer -> ViewPattern -> m View newBufferView b pat = View <$> liftIO (newIORef (SourceBuffer b,pat)) -- | Create a weak view on a buffer@@ -208,7 +208,7 @@ -- buffer so that the copying cost is balanced by the memory occupation -- difference. ---newBufferWeakView :: MonadIO m => Buffer 'Immutable pin fin heap -> ViewPattern -> m View+newBufferWeakView :: MonadIO m => Buffer -> ViewPattern -> m View newBufferWeakView b pat = do -- temporarily create a View that non-weakly references the buffer v <- View <$> (liftIO $ newIORef (SourceBuffer b,pat))@@ -221,7 +221,7 @@ assignBufferWeakView :: MonadIO m => View- -> Buffer 'Immutable pin fin heap+ -> Buffer -> ViewPattern -> m () assignBufferWeakView (View ref) b pat = do@@ -236,14 +236,14 @@ bufferWeakViewFinalier- :: Buffer 'Immutable pin fin heap -- ^ Source buffer- -> ViewPattern -- ^ View pattern- -> Weak ViewIORef -- ^ Weak IORef of the view+ :: Buffer -- ^ Source buffer+ -> ViewPattern -- ^ View pattern+ -> Weak ViewIORef -- ^ Weak IORef of the view -> IO () bufferWeakViewFinalier b pat wViewRef = deRefWeak wViewRef >>= \case Nothing -> return () -- the view is dead Just viewRef -> do- bsz <- bufferSizeIO b+ bsz <- bufferSize b newSrc <- case pat of -- this is stupid (the view covers the whole buffer) but let's resurrect b PatternFull -> return (SourceBuffer b)@@ -254,8 +254,7 @@ _ -> do -- we allocate a new buffer and copy the contents in it b' <- copyBufferWithPattern b pat- b'' <- unsafeBufferFreeze b'- return (SourceBuffer b'')+ return (SourceBuffer b') -- update the view IORef writeIORef viewRef (newSrc,PatternFull)@@ -290,7 +289,7 @@ liftIO (writeIORef ref (SourceWeakView wSrcRef,pat)) -- we don't want the finalizer to run before we write the IORef- liftIO (touch srcRef)+ -- FIXME: liftIO (touch srcRef) viewWeakViewFinalizer :: Weak ViewIORef -> ViewIORef -> ViewPattern -> IO () viewWeakViewFinalizer weakView srcRef pat = deRefWeak weakView >>= \case@@ -314,28 +313,28 @@ -- | Allocate a new buffer initialized with the contents of the source buffer -- according to the given pattern-copyBufferWithPattern :: Buffer mut pin fin heap -> ViewPattern -> IO BufferM+copyBufferWithPattern :: Buffer -> ViewPattern -> IO Buffer copyBufferWithPattern b pat = do- bsz <- bufferSizeIO b+ bsz <- bufferSize b let !sz = patternSize pat bsz b' <- newBuffer sz case pat of PatternFull -> error "Unreachable code"- Pattern1D poff psz -> copyBuffer b poff b' 0 psz+ Pattern1D poff psz -> bufferCopy b poff b' 0 psz Pattern2D poff w h stride -> forM_ [0..h-1] $ \r ->- copyBuffer b (poff + r*(w+stride)) b' (r*w) w+ bufferCopy b (poff + r*(w+stride)) b' (r*w) w PatternOn _p1 _p2 -> forM_ [0..sz-1] $ \off -> do -- Not very efficient to copy byte by byte...- v <- bufferReadWord8IO b (patternOffset pat off)- bufferWriteWord8IO b' off v+ v <- bufferReadWord8 b (patternOffset pat off)+ bufferWriteWord8 b' off v return b' -- | Convert a view into an actual buffer-viewToBuffer :: View -> IO BufferM+viewToBuffer :: View -> IO Buffer viewToBuffer = go PatternFull where- go :: ViewPattern -> View -> IO BufferM+ go :: ViewPattern -> View -> IO Buffer go pat v = withValidView v (\b pat2 -> copyBufferWithPattern b (pat `patternApplyOn` pat2)) (\b pat2 -> copyBufferWithPattern b (pat `patternApplyOn` pat2))@@ -345,7 +344,7 @@ -- -- >>> :set -XOverloadedLists -- >>> import System.Mem--- >>> v <- newBufferWeakView ([10,11,12,13,14,15,16,17] :: BufferI) (Pattern1D 2 4)+-- >>> v <- newBufferWeakView ([10,11,12,13,14,15,16,17] :: Buffer) (Pattern1D 2 4) -- >>> v2 <- newViewWeakView v (Pattern1D 1 1) -- -- > putStr =<< showViewState v2@@ -371,13 +370,13 @@ -- View pattern: PatternFull -- Wasted space: 0% ---showViewState :: MonadIO m => View -> m String+showViewState :: View -> IO String showViewState = fmap fst . go where go v = withValidView v (\b pat -> do- sz <- bufferSizeIO b+ sz <- bufferSize b let psz = patternSize pat sz return (unlines [ "View source: buffer"@@ -387,7 +386,7 @@ ], psz) ) (\b pat -> do- sz <- bufferSizeIO b+ sz <- bufferSize b let psz = patternSize pat sz return (unlines [ "View source: weak buffer"
src/lib/Haskus/Number/Posit.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}