diff --git a/haskus-binary.cabal b/haskus-binary.cabal --- a/haskus-binary.cabal +++ b/haskus-binary.cabal @@ -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 diff --git a/src/lib/Haskus/Binary/BitField.hs b/src/lib/Haskus/Binary/BitField.hs --- a/src/lib/Haskus/Binary/BitField.hs +++ b/src/lib/Haskus/Binary/BitField.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Bits/Bitwise.hs b/src/lib/Haskus/Binary/Bits/Bitwise.hs --- a/src/lib/Haskus/Binary/Bits/Bitwise.hs +++ b/src/lib/Haskus/Binary/Bits/Bitwise.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Bits/Finite.hs b/src/lib/Haskus/Binary/Bits/Finite.hs --- a/src/lib/Haskus/Binary/Bits/Finite.hs +++ b/src/lib/Haskus/Binary/Bits/Finite.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Bits/Get.hs b/src/lib/Haskus/Binary/Bits/Get.hs --- a/src/lib/Haskus/Binary/Bits/Get.hs +++ b/src/lib/Haskus/Binary/Bits/Get.hs @@ -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' diff --git a/src/lib/Haskus/Binary/Bits/Index.hs b/src/lib/Haskus/Binary/Bits/Index.hs --- a/src/lib/Haskus/Binary/Bits/Index.hs +++ b/src/lib/Haskus/Binary/Bits/Index.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Bits/Put.hs b/src/lib/Haskus/Binary/Bits/Put.hs --- a/src/lib/Haskus/Binary/Bits/Put.hs +++ b/src/lib/Haskus/Binary/Bits/Put.hs @@ -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' diff --git a/src/lib/Haskus/Binary/Bits/Shift.hs b/src/lib/Haskus/Binary/Bits/Shift.hs --- a/src/lib/Haskus/Binary/Bits/Shift.hs +++ b/src/lib/Haskus/Binary/Bits/Shift.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Enum.hs b/src/lib/Haskus/Binary/Enum.hs --- a/src/lib/Haskus/Binary/Enum.hs +++ b/src/lib/Haskus/Binary/Enum.hs @@ -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) diff --git a/src/lib/Haskus/Binary/Get.hs b/src/lib/Haskus/Binary/Get.hs --- a/src/lib/Haskus/Binary/Get.hs +++ b/src/lib/Haskus/Binary/Get.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Record.hs b/src/lib/Haskus/Binary/Record.hs --- a/src/lib/Haskus/Binary/Record.hs +++ b/src/lib/Haskus/Binary/Record.hs @@ -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) diff --git a/src/lib/Haskus/Binary/Serialize/Buffer.hs b/src/lib/Haskus/Binary/Serialize/Buffer.hs --- a/src/lib/Haskus/Binary/Serialize/Buffer.hs +++ b/src/lib/Haskus/Binary/Serialize/Buffer.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Serialize/File.hs b/src/lib/Haskus/Binary/Serialize/File.hs --- a/src/lib/Haskus/Binary/Serialize/File.hs +++ b/src/lib/Haskus/Binary/Serialize/File.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Serialize/Get.hs b/src/lib/Haskus/Binary/Serialize/Get.hs --- a/src/lib/Haskus/Binary/Serialize/Get.hs +++ b/src/lib/Haskus/Binary/Serialize/Get.hs @@ -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 () diff --git a/src/lib/Haskus/Binary/Serialize/Put.hs b/src/lib/Haskus/Binary/Serialize/Put.hs --- a/src/lib/Haskus/Binary/Serialize/Put.hs +++ b/src/lib/Haskus/Binary/Serialize/Put.hs @@ -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 -- diff --git a/src/lib/Haskus/Binary/Serialize/Size.hs b/src/lib/Haskus/Binary/Serialize/Size.hs --- a/src/lib/Haskus/Binary/Serialize/Size.hs +++ b/src/lib/Haskus/Binary/Serialize/Size.hs @@ -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)) diff --git a/src/lib/Haskus/Binary/Union.hs b/src/lib/Haskus/Binary/Union.hs --- a/src/lib/Haskus/Binary/Union.hs +++ b/src/lib/Haskus/Binary/Union.hs @@ -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 diff --git a/src/lib/Haskus/Binary/Unum.hs b/src/lib/Haskus/Binary/Unum.hs --- a/src/lib/Haskus/Binary/Unum.hs +++ b/src/lib/Haskus/Binary/Unum.hs @@ -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. diff --git a/src/lib/Haskus/Memory/Allocator/Malloc.hs b/src/lib/Haskus/Memory/Allocator/Malloc.hs --- a/src/lib/Haskus/Memory/Allocator/Malloc.hs +++ b/src/lib/Haskus/Memory/Allocator/Malloc.hs @@ -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) diff --git a/src/lib/Haskus/Memory/Buffer.hs b/src/lib/Haskus/Memory/Buffer.hs --- a/src/lib/Haskus/Memory/Buffer.hs +++ b/src/lib/Haskus/Memory/Buffer.hs @@ -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) diff --git a/src/lib/Haskus/Memory/Embed.hs b/src/lib/Haskus/Memory/Embed.hs --- a/src/lib/Haskus/Memory/Embed.hs +++ b/src/lib/Haskus/Memory/Embed.hs @@ -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 diff --git a/src/lib/Haskus/Memory/Typed.hs b/src/lib/Haskus/Memory/Typed.hs --- a/src/lib/Haskus/Memory/Typed.hs +++ b/src/lib/Haskus/Memory/Typed.hs @@ -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 ()) diff --git a/src/lib/Haskus/Memory/View.hs b/src/lib/Haskus/Memory/View.hs --- a/src/lib/Haskus/Memory/View.hs +++ b/src/lib/Haskus/Memory/View.hs @@ -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" diff --git a/src/lib/Haskus/Number/Posit.hs b/src/lib/Haskus/Number/Posit.hs --- a/src/lib/Haskus/Number/Posit.hs +++ b/src/lib/Haskus/Number/Posit.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}