diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog for primal-memory +## 0.3.0 + +* Rename many functions that perform mutation. Add `Mut` infix to operations that deal + with mutable source memory regions. +* Rename `resizeMem` -> `reallocMutMem` +* Export `defaultReallocMutMem` +* Rename `PrimArray` -> `PArray` and `MPrimArray` -> `PMArray` + ## 0.2.0 * Rename `ByteArray` -> `PrimArray` diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,8 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import GHC.Exts @@ -11,12 +12,16 @@ import Criterion.Main import Data.Prim.Memory.Bytes import Data.Prim.Memory.Ptr -import Control.Prim.Monad import qualified Data.Primitive.Types as BA import qualified Data.Primitive.ByteArray as BA -import qualified Control.Monad.Primitive as BA import Foreign.Storable as S +import Foreign.ForeignPtr +import GHC.ForeignPtr +import Control.DeepSeq +instance NFData (ForeignPtr a) where + rnf !_ = () + main :: IO () main = do let n = 1000000 :: Count a @@ -102,16 +107,12 @@ ] , bgroup "peek" - [ benchPeek (Proxy :: Proxy Word8) mb1 mba - , benchPeek (Proxy :: Proxy Word16) mb1 mba - , benchPeek (Proxy :: Proxy Word32) mb1 mba - , benchPeek (Proxy :: Proxy Word64) mb1 mba - , benchPeek (Proxy :: Proxy Char) mb1 mba - , bgroup - "Bool" - [ bench "Bytes" $ - whnfIO (withPtrMBytes mb1 (readPtr :: Ptr Bool -> IO Bool)) - ] + [ env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Word8) mb1) + , env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Word16) mb1) + , env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Word32) mb1) + , env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Word64) mb1) + , env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Char) mb1) + , env mallocPlainForeignPtr (benchPeek (Proxy :: Proxy Bool) mb1) ] ] ] @@ -145,20 +146,16 @@ where i = 100 benchPeek :: - forall a. (Typeable a, Prim a, BA.Prim a) + forall a. (Typeable a, Prim a, S.Storable a) => Proxy a -> MBytes 'Pin RealWorld - -> BA.MutableByteArray RealWorld + -> ForeignPtr a -> Benchmark -benchPeek px mb mba = +benchPeek px mb fptr = bgroup (showsType px "") [ bench "Bytes" $ whnfIO $ withPtrMBytes mb (readPtr :: Ptr a -> IO a) - , bench "ByteArray" $ - whnfIO $ do - let ptr = BA.mutableByteArrayContents mba - res <- S.peek ptr - res <$ BA.touch mba + , bench "ForeignPtr" $ whnfIO $ withForeignPtr fptr S.peek ] setBytesBench :: diff --git a/bench/Compare.hs b/bench/Compare.hs new file mode 100644 --- /dev/null +++ b/bench/Compare.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Criterion.Main +import Data.Prim.Memory +import Data.Prim.Memory.Addr +import Data.Prim.Memory.Bytes +import Data.Prim.Memory.ByteString +import Data.Prim.Memory.PArray +import qualified Data.Primitive.ByteArray as BA +import Data.Primitive.PrimArray + +main :: IO () +main = do + let n = 1000000 :: Count a + n64 = n :: Count Word64 + -- Ensure that arrays are equal by filling them with zeros + bEq1 <- freezeMBytes =<< allocZeroAlignedMBytes n64 + bEq2 <- freezeMBytes =<< allocZeroAlignedMBytes n64 + mbaEq1 <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 + mbaEq2 <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 + BA.setByteArray mbaEq1 0 (unCount n64) (0 :: Word64) + BA.setByteArray mbaEq2 0 (unCount n64) (0 :: Word64) + baEq1 <- BA.unsafeFreezeByteArray mbaEq1 + baEq2 <- BA.unsafeFreezeByteArray mbaEq2 + let paEq1 = PArray bEq1 :: PArray 'Pin Word64 + paEq2 = PArray bEq2 :: PArray 'Pin Word64 + bsEq1 = convertMem bEq1 :: ByteString + bsEq2 = convertMem bEq2 :: ByteString + addrEq1 = fromBytesAddr bEq1 :: Addr Word64 + addrEq2 = fromBytesAddr bEq2 :: Addr Word64 + primEq1 = PrimArray (toByteArray# bEq1) :: PrimArray Word64 + primEq2 = PrimArray (toByteArray# bEq2) :: PrimArray Word64 + pa8Eq1 = PArray bEq1 :: PArray 'Pin Word8 + pa8Eq2 = PArray bEq2 :: PArray 'Pin Word8 + addr8Eq1 = fromBytesAddr bEq1 :: Addr Word8 + addr8Eq2 = fromBytesAddr bEq2 :: Addr Word8 + prim8Eq1 = PrimArray (toByteArray# bEq1) :: PrimArray Word8 + prim8Eq2 = PrimArray (toByteArray# bEq2) :: PrimArray Word8 + + addr16Eq1 = fromBytesAddr bEq1 :: Addr Word16 + addr16Eq2 = fromBytesAddr bEq2 :: Addr Word16 + pa16Eq1 = PArray bEq1 :: PArray 'Pin Word16 + pa16Eq2 = PArray bEq2 :: PArray 'Pin Word16 + prim16Eq1 = PrimArray (toByteArray# bEq1) :: PrimArray Word16 + prim16Eq2 = PrimArray (toByteArray# bEq2) :: PrimArray Word16 + addr32Eq1 = fromBytesAddr bEq1 :: Addr Word32 + addr32Eq2 = fromBytesAddr bEq2 :: Addr Word32 + pa32Eq1 = PArray bEq1 :: PArray 'Pin Word32 + pa32Eq2 = PArray bEq2 :: PArray 'Pin Word32 + prim32Eq1 = PrimArray (toByteArray# bEq1) :: PrimArray Word32 + prim32Eq2 = PrimArray (toByteArray# bEq2) :: PrimArray Word32 + defaultMain + [ bgroup + "eq" + [ bgroup + "Word8" + [ bench "Bytes" $ whnf (bEq1 ==) bEq2 + , bench "ByteArray" $ whnf (baEq1 ==) baEq2 + , bench "ByteString" $ whnf (bsEq1 ==) bsEq2 + , bench "Addr" $ whnf (addr8Eq1 ==) addr8Eq2 + , bench "PArray" $ whnf (pa8Eq1 ==) pa8Eq2 + , bench "PrimArray" $ whnf (prim8Eq1 ==) prim8Eq2 + ] + , bgroup + "Word64" + [ bench "Addr" $ whnf (addrEq1 ==) addrEq2 + , bench "PArray" $ whnf (paEq1 ==) paEq2 + , bench "PrimArray" $ whnf (primEq1 ==) primEq2 + ] + ] + , bgroup + "compare" + [ bgroup + "Word8" + [ bench "Bytes" $ whnf (compare bEq1) bEq2 + , bench "ByteArray" $ whnf (compare baEq1) baEq2 + , bench "ByteString" $ whnf (compare bsEq1) bsEq2 + , bench "Addr" $ whnf (compare addr8Eq1) addr8Eq2 + , bench "PArray" $ whnf (compare pa8Eq1) pa8Eq2 + , bench "PrimArray" $ whnf (compare prim8Eq1) prim8Eq2 + ] + , bgroup + "Word16" + [ bench "Addr" $ whnf (compare addr16Eq1) addr16Eq2 + , bench "PArray" $ whnf (compare pa16Eq1) pa16Eq2 + , bench "PrimArray" $ whnf (compare prim16Eq1) prim16Eq2 + ] + , bgroup + "Word32" + [ bench "Addr" $ whnf (compare addr32Eq1) addr32Eq2 + , bench "PArray" $ whnf (compare pa32Eq1) pa32Eq2 + , bench "PrimArray" $ whnf (compare prim32Eq1) prim32Eq2 + ] + , bgroup + "Word64" + [ bench "Addr" $ whnf (compare addrEq1) addrEq2 + , bench "PArray" $ whnf (compare paEq1) paEq2 + , bench "PrimArray" $ whnf (compare primEq1) primEq2 + ] + ] + ] diff --git a/bench/Conversion.hs b/bench/Conversion.hs --- a/bench/Conversion.hs +++ b/bench/Conversion.hs @@ -5,15 +5,16 @@ module Main (main) where -import GHC.Exts +import Control.Prim.Eval +import Control.Prim.Monad import Criterion.Main import Data.Prim.Memory.Bytes +import Data.Prim.Memory.ForeignPtr import Data.Prim.Memory.Ptr -import Control.Prim.Monad +import qualified Data.Primitive.ByteArray as BA import qualified Foreign.ForeignPtr as GHC import Foreign.Storable -import Data.Prim.Memory.ForeignPtr -import qualified Data.Primitive.ByteArray as BA +import Foreign.Prim main :: IO () main = do @@ -28,8 +29,8 @@ mba <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 ba <- BA.unsafeFreezeByteArray mba -- Ensure that arrays are equal by filling them with zeros - bEq1 <- freezeMBytes =<< callocAlignedMBytes n64 - bEq2 <- freezeMBytes =<< callocAlignedMBytes n64 + bEq1 <- freezeMBytes =<< allocZeroAlignedMBytes n64 + bEq2 <- freezeMBytes =<< allocZeroAlignedMBytes n64 mbaEq1 <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 mbaEq2 <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 BA.setByteArray mbaEq1 0 (unCount n64) (0 :: Word64) @@ -81,7 +82,7 @@ ] , bgroup "fromListN" - [ bench "Bytes" $ whnf (fromListBytesN_ n :: [Int] -> Bytes 'Inc) xs + [ bench "Bytes" $ whnf (fromListZeroBytesN_ n :: [Int] -> Bytes 'Inc) xs , bench "ByteArray" $ whnf (BA.byteArrayFromListN (unCount n)) xs ] ] diff --git a/primal-memory.cabal b/primal-memory.cabal --- a/primal-memory.cabal +++ b/primal-memory.cabal @@ -1,5 +1,5 @@ name: primal-memory -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Unified interface for memory managemenet. description: Please see the README on GitHub at homepage: https://github.com/lehins/primal @@ -13,13 +13,15 @@ extra-source-files: README.md , CHANGELOG.md cabal-version: 1.18 -tested-with: GHC == 8.4.3 +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.3 , GHC == 8.4.4 , GHC == 8.6.3 , GHC == 8.6.4 , GHC == 8.6.5 - , GHC == 8.8.1 - , GHC == 8.8.2 + , GHC == 8.8.3 + , GHC == 8.8.4 , GHC == 8.10.1 library @@ -29,7 +31,8 @@ , Data.Prim.Memory.ByteString , Data.Prim.Memory.Bytes , Data.Prim.Memory.ForeignPtr - , Data.Prim.Memory.PrimArray + , Data.Prim.Memory.Fold + , Data.Prim.Memory.PArray , Data.Prim.Memory.Ptr , Data.Prim.Memory.Text , Data.Prim.Memory.Internal @@ -66,7 +69,6 @@ ghc-options: -Wall -threaded -O2 - -with-rtsopts=-N build-depends: base , criterion , primal @@ -83,7 +85,6 @@ ghc-options: -Wall -threaded -O2 - -with-rtsopts=-N build-depends: base , criterion , primal @@ -93,6 +94,22 @@ , random default-language: Haskell2010 +benchmark compare + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Compare.hs + ghc-options: -Wall + -threaded + -O2 + build-depends: base + , criterion + , primal + , primal-memory + , primitive + , deepseq + , random + default-language: Haskell2010 + source-repository head type: git - location: https://github.com/lehins/prim-bytes + location: https://github.com/lehins/primal diff --git a/src/Data/Prim/Memory.hs b/src/Data/Prim/Memory.hs --- a/src/Data/Prim/Memory.hs +++ b/src/Data/Prim/Memory.hs @@ -6,6 +6,8 @@ -- Stability : experimental -- Portability : non-portable -- +{-# LANGUAGE BangPatterns #-} + module Data.Prim.Memory ( module Data.Prim , Pinned(..) @@ -35,7 +37,12 @@ , copyByteOffToPtrMem -- DOC: [x], DOCTEST [ ], TEST: [x] -- ** Compare , eqMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , eqOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , eqByteMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , eqByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] , compareMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , compareOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , compareByteMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] , compareByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] , compareByteOffToPtrMem -- DOC: [x], DOCTEST [ ], TEST: [x] , compareByteOffToBytesMem -- DOC: [x], DOCTEST [ ], TEST: [x] @@ -60,47 +67,51 @@ , MemAlloc(FrozenMem) , MemState(..) -- ** Size - , getCountMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , getCountRemMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , getByteCountMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , getCountMutMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , getCountRemMutMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , getByteCountMutMem -- DOC: [x], DOCTEST [x], TEST: [ ] -- ** Read - , readOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , readByteOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , readOffMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , readByteOffMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] -- ** Write - , writeOffMem -- DOC: [x], DOCTEST [ ], TEST: [x] - , writeByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [x] - , setMem -- DOC: [x], DOCTEST [ ], TEST: [x] - , modifyFetchOldMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , modifyFetchOldMemM -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , modifyFetchNewMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , modifyFetchNewMemM -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , writeOffMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , writeByteOffMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , setMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , modifyFetchOldMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , modifyFetchOldMutMemM -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , modifyFetchNewMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , modifyFetchNewMutMemM -- DOC: [ ], DOCTEST [ ], TEST: [ ] -- ** Allocate - , allocMem -- DOC: [x], DOCTEST [ ], TEST: [ ] - , allocZeroMem -- DOC: [x], DOCTEST [x], TEST: [ ] - , thawMem -- DOC: [x], DOCTEST [ ], TEST: [ ] - , thawCloneMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , thawCopyMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , freezeMem -- DOC: [x], DOCTEST [ ], TEST: [ ] - , freezeCloneMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , freezeCopyMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , resizeMem -- DOC: [x], DOCTEST [ ], TEST: [ ] - , withScrubbedMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , allocMutMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , allocZeroMutMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , reallocMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , withScrubbedMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , defaultReallocMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + -- ** Thaw/Freeze + , thawCloneMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , thawCopyMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , thawMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , freezeCloneMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , freezeCopyMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , freezeMutMem -- DOC: [x], DOCTEST [ ], TEST: [ ] -- ** Move - , moveMem -- DOC: [ ], DOCTEST [ ], TEST: [x] - , moveByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] - , moveByteOffToMBytesMem -- DOC: [x], DOCTEST [ ], TEST: [x] - , moveByteOffToPtrMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , cloneMutMem -- DOC: [x], DOCTEST [ ], TEST: [-] + , moveMutMem -- DOC: [ ], DOCTEST [ ], TEST: [x] + , moveByteOffMutMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , moveByteOffToMBytesMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , moveByteOffToPtrMutMem -- DOC: [x], DOCTEST [ ], TEST: [x] -- ** Load list - , loadListMem -- DOC: [x], DOCTEST [x], TEST: [x] - , loadListMem_ -- DOC: [x], DOCTEST [x], TEST: [ ] - , loadListMemN -- DOC: [x], DOCTEST [ ], TEST: [ ] - , loadListMemN_ -- DOC: [x], DOCTEST [ ], TEST: [ ] + , loadListMutMem -- DOC: [x], DOCTEST [x], TEST: [x] + , loadListMutMem_ -- DOC: [x], DOCTEST [x], TEST: [ ] + , loadListMutMemN -- DOC: [x], DOCTEST [ ], TEST: [ ] + , loadListMutMemN_ -- DOC: [x], DOCTEST [ ], TEST: [ ] -- *** With offset - , loadListOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , loadListOffMemN -- DOC: [ ], DOCTEST [ ], TEST: [ ] - , loadListByteOffMem -- DOC: [x], DOCTEST [x], TEST: [ ] - , loadListByteOffMemN -- DOC: [x], DOCTEST [x], TEST: [ ] + , loadListOffMutMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , loadListOffMutMemN -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , loadListByteOffMutMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , loadListByteOffMutMemN -- DOC: [x], DOCTEST [x], TEST: [ ] ) where import Data.Prim import Data.Prim.Memory.Internal +import Data.Prim.Memory.Fold diff --git a/src/Data/Prim/Memory/Addr.hs b/src/Data/Prim/Memory/Addr.hs --- a/src/Data/Prim/Memory/Addr.hs +++ b/src/Data/Prim/Memory/Addr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -- | @@ -24,6 +26,7 @@ , byteCountAddr , countAddr , plusOffAddr + , plusByteOffAddr , indexAddr , indexOffAddr , indexByteOffAddr @@ -39,8 +42,11 @@ -- * Mutable MAddr , MAddr(..) , castMAddr + , newMAddr , allocMAddr - , callocMAddr + , allocAlignedMAddr + , allocZeroMAddr + , allocZeroAlignedMAddr , reallocMAddr , shrinkMAddr , shrinkByteCountMAddr @@ -49,6 +55,7 @@ , getByteCountMAddr , getCountMAddr , plusOffMAddr + , plusByteOffMAddr , readMAddr , readOffMAddr , readByteOffMAddr @@ -58,6 +65,18 @@ , copyAddrToMAddr , moveMAddrToMAddr + + , modifyMAddr + , modifyMAddr_ + , modifyFetchOldMAddr + , modifyFetchNewMAddr + , modifyMAddrM + , modifyMAddrM_ + , modifyFetchOldMAddrM + , modifyFetchNewMAddrM + , swapMAddrs_ + , swapMAddrs + , withPtrMAddr , withAddrMAddr# , withNoHaltPtrMAddr @@ -124,6 +143,7 @@ import Control.Arrow (first) import Control.DeepSeq +import Control.Prim.Eval import Control.Prim.Monad import Control.Prim.Monad.Unsafe import Data.ByteString.Internal @@ -136,6 +156,7 @@ import Data.Prim.Memory.Bytes import Data.Prim.Memory.Bytes.Internal import Data.Prim.Memory.ByteString +import Data.Prim.Memory.Fold import Data.Prim.Memory.ForeignPtr import Data.Prim.Memory.Internal import Data.Prim.Memory.Ptr @@ -147,22 +168,27 @@ -- | Immutable read-only address data Addr e = Addr { addrAddr# :: Addr# - , addrBytes :: {-# UNPACK #-}!(Bytes 'Pin) + , addrBytes :: Bytes 'Pin } type role Addr nominal -- | Mutable address data MAddr e s = MAddr { mAddrAddr# :: Addr# - , mAddrMBytes :: {-# UNPACK #-}!(MBytes 'Pin s) + , mAddrMBytes :: MBytes 'Pin s } type role MAddr nominal nominal +instance (Eq e, Prim e) => Eq (Addr e) where + (==) = eqMem @e + {-# INLINE (==) #-} -instance Eq (Addr e) where - a1 == a2 = isSameAddr a1 a2 || eqMem a1 a2 +instance (Prim e, Ord e) => Ord (Addr e) where + compare = compareMem @e + {-# INLINE compare #-} + instance (Show e, Prim e) => Show (Addr e) where show a = show (toListMem a :: [e]) @@ -177,20 +203,28 @@ instance Semigroup.Semigroup (Addr e) where (<>) = appendMem + {-# INLINE (<>) #-} sconcat (x :| xs) = concatMem (x:xs) + {-# INLINE sconcat #-} stimes i = cycleMemN (fromIntegral i) + {-# INLINE stimes #-} instance Monoid.Monoid (Addr e) where mappend = appendMem + {-# INLINE mappend #-} mconcat = concatMem + {-# INLINE mconcat #-} mempty = emptyMem + {-# INLINE mempty #-} castAddr :: Addr e -> Addr b castAddr (Addr a b) = Addr a b +{-# INLINE castAddr #-} castMAddr :: MAddr e s -> MAddr b s castMAddr (MAddr a mb) = MAddr a mb +{-# INLINE castMAddr #-} castStateMAddr :: MAddr e s' -> MAddr b s castStateMAddr = unsafeCoerce @@ -198,6 +232,9 @@ isSameAddr :: Addr e -> Addr e -> Bool isSameAddr (Addr a1# _) (Addr a2# _) = isTrue# (a1# `eqAddr#` a2#) +isSameMAddr :: MAddr e s -> MAddr e s -> Bool +isSameMAddr (MAddr a1# _) (MAddr a2# _) = isTrue# (a1# `eqAddr#` a2#) + instance NFData (Addr e) where rnf (Addr _ _) = () @@ -214,14 +251,29 @@ fromMBytesMAddr mb = case toPtrMBytes mb of Ptr addr# -> MAddr addr# mb +{-# INLINE fromMBytesMAddr #-} -allocMAddr :: (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) -allocMAddr c = fromMBytesMAddr <$> allocAlignedMBytes c +newMAddr :: forall e m s. (MonadPrim s m, Prim e) => e -> m (MAddr e s) +newMAddr e = do + maddr <- fromMBytesMAddr <$> allocPinnedMBytes (1 :: Count e) + writeMAddr maddr e + pure $! maddr +{-# INLINE newMAddr #-} -callocMAddr :: (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) -callocMAddr c = fromMBytesMAddr <$> callocAlignedMBytes c +allocMAddr :: forall e m s. (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) +allocMAddr c = fromMBytesMAddr <$> allocPinnedMBytes c +allocZeroMAddr :: forall e m s. (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) +allocZeroMAddr c = fromMBytesMAddr <$> allocZeroPinnedMBytes c + +allocAlignedMAddr :: forall e m s. (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) +allocAlignedMAddr c = fromMBytesMAddr <$> allocAlignedMBytes c + +allocZeroAlignedMAddr :: forall e m s. (MonadPrim s m, Prim e) => Count e -> m (MAddr e s) +allocZeroAlignedMAddr c = fromMBytesMAddr <$> allocZeroAlignedMBytes c + + -- | Shrink mutable address to new specified size in number of elements. The new count -- must be less than or equal to the current as reported by `getCountMAddr`. shrinkMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Count e -> m () @@ -253,9 +305,15 @@ plusOffAddr :: Prim e => Addr e -> Off e -> Addr e plusOffAddr (Addr addr# b) off = Addr (addr# `plusAddr#` unOffBytes# off) b +plusByteOffAddr :: Addr e -> Off Word8 -> Addr e +plusByteOffAddr (Addr addr# b) off = Addr (addr# `plusAddr#` unOffBytes# off) b + plusOffMAddr :: Prim e => MAddr e s -> Off e -> MAddr e s plusOffMAddr (MAddr addr# mb) off = MAddr (addr# `plusAddr#` unOffBytes# off) mb +plusByteOffMAddr :: MAddr e s -> Off Word8 -> MAddr e s +plusByteOffMAddr (MAddr addr# mb) off = MAddr (addr# `plusAddr#` unOffBytes# off) mb + curOffAddr :: Prim e => Addr e -> Off e curOffAddr a@(Addr addr# b) = (Ptr addr# `minusOffPtr` toPtrBytes b) `offForProxyTypeOf` a @@ -280,9 +338,12 @@ indexAddr :: Prim e => Addr e -> e indexAddr addr = indexOffAddr addr 0 +{-# INLINE indexAddr #-} indexOffAddr :: Prim e => Addr e -> Off e -> e -indexOffAddr addr off = unsafeInlineIO $ readOffAddr addr off +indexOffAddr addr (Off (I# off#)) = + unsafeInlineIO $ withAddrAddr# addr $ \addr# -> pure $ indexOffAddr# addr# off# +{-# INLINE indexOffAddr #-} indexByteOffAddr :: Prim e => Addr e -> Off Word8 -> e indexByteOffAddr addr off = unsafeInlineIO $ readByteOffAddr addr off @@ -298,7 +359,7 @@ {-# INLINE withAddrAddr# #-} withNoHaltPtrAddr :: MonadUnliftPrim s m => Addr e -> (Ptr e -> m b) -> m b -withNoHaltPtrAddr (Addr addr# b) f = withAliveUnliftPrim b $ f (Ptr addr#) +withNoHaltPtrAddr (Addr addr# b) f = keepAlive b $ f (Ptr addr#) {-# INLINE withNoHaltPtrAddr #-} curOffMAddr :: forall e s . Prim e => MAddr e s -> Off e @@ -362,7 +423,7 @@ {-# INLINE withAddrMAddr# #-} withNoHaltPtrMAddr :: MonadUnliftPrim s m => MAddr e s -> (Ptr e -> m b) -> m b -withNoHaltPtrMAddr (MAddr addr# mb) f = withAliveUnliftPrim mb $ f (Ptr addr#) +withNoHaltPtrMAddr (MAddr addr# mb) f = keepAlive mb $ f (Ptr addr#) {-# INLINE withNoHaltPtrMAddr #-} @@ -388,19 +449,21 @@ instance MemAlloc (MAddr e) where type FrozenMem (MAddr e) = Addr e - getByteCountMem = getByteCountMAddr - {-# INLINE getByteCountMem #-} - allocMem = fmap castMAddr . allocMAddr - {-# INLINE allocMem #-} + getByteCountMutMem = getByteCountMAddr + {-# INLINE getByteCountMutMem #-} + allocMutMem = fmap castMAddr . allocMAddr + {-# INLINE allocMutMem #-} thawMem = thawAddr {-# INLINE thawMem #-} - freezeMem = freezeMAddr - {-# INLINE freezeMem #-} - resizeMem maddr = fmap castMAddr . reallocMAddr (castMAddr maddr) - {-# INLINE resizeMem #-} + freezeMutMem = freezeMAddr + {-# INLINE freezeMutMem #-} + reallocMutMem maddr = fmap castMAddr . reallocMAddr (castMAddr maddr) + {-# INLINE reallocMutMem #-} instance MemRead (Addr e) where + isSameMem = isSameAddr + {-# INLINE isSameMem #-} byteCountMem = byteCountAddr {-# INLINE byteCountMem #-} indexOffMem a i = unsafeInlineIO $ withAddrAddr# a $ \addr# -> readOffPtr (Ptr addr#) i @@ -425,32 +488,34 @@ {-# INLINE compareByteOffMem #-} instance MemWrite (MAddr e) where - readOffMem a = readOffMAddr (castMAddr a) - {-# INLINE readOffMem #-} - readByteOffMem a = readByteOffMAddr (castMAddr a) - {-# INLINE readByteOffMem #-} - writeOffMem a = writeOffMAddr (castMAddr a) - {-# INLINE writeOffMem #-} - writeByteOffMem a = writeByteOffMAddr (castMAddr a) - {-# INLINE writeByteOffMem #-} - moveByteOffToPtrMem src srcOff dstPtr dstOff c = + isSameMutMem = isSameMAddr + {-# INLINE isSameMutMem #-} + readOffMutMem a = readOffMAddr (castMAddr a) + {-# INLINE readOffMutMem #-} + readByteOffMutMem a = readByteOffMAddr (castMAddr a) + {-# INLINE readByteOffMutMem #-} + writeOffMutMem a = writeOffMAddr (castMAddr a) + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem a = writeByteOffMAddr (castMAddr a) + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem src srcOff dstPtr dstOff c = withAddrMAddr# src $ \ srcAddr# -> moveByteOffPtrToPtr (Ptr srcAddr#) srcOff dstPtr dstOff c - {-# INLINE moveByteOffToPtrMem #-} - moveByteOffToMBytesMem src srcOff dst dstOff c = + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem src srcOff dst dstOff c = withAddrMAddr# src $ \ srcAddr# -> moveByteOffPtrToMBytes (Ptr srcAddr#) srcOff dst dstOff c - {-# INLINE moveByteOffToMBytesMem #-} + {-# INLINE moveByteOffToMBytesMutMem #-} copyByteOffMem src srcOff dst dstOff c = withAddrMAddr# dst $ \ dstAddr# -> copyByteOffToPtrMem src srcOff (Ptr dstAddr#) dstOff c {-# INLINE copyByteOffMem #-} - moveByteOffMem src srcOff dst dstOff c = + moveByteOffMutMem src srcOff dst dstOff c = withAddrMAddr# dst $ \ dstAddr# -> - moveByteOffToPtrMem src srcOff (Ptr dstAddr#) dstOff c - {-# INLINE moveByteOffMem #-} - setMem maddr = setMAddr (castMAddr maddr) - {-# INLINE setMem #-} + moveByteOffToPtrMutMem src srcOff (Ptr dstAddr#) dstOff c + {-# INLINE moveByteOffMutMem #-} + setMutMem maddr = setMAddr (castMAddr maddr) + {-# INLINE setMutMem #-} @@ -464,25 +529,27 @@ readAddr :: (MonadPrim s m, Prim e) => Addr e -> m e -readAddr addr = readOffAddr addr 0 +readAddr (Addr addr# b) = do + a <- prim (readOffAddr# addr# 0#) + a <$ touch b {-# INLINE readAddr #-} readOffAddr :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m e readOffAddr (Addr addr# b) (Off (I# off#)) = do - -- TODO: benchmark and see if `readOffAddr` is faster here - a <- prim (seq# (indexOffAddr# addr# off#)) + a <- prim (readOffAddr# addr# off#) a <$ touch b {-# INLINE readOffAddr #-} readByteOffAddr :: (MonadPrim s m, Prim e) => Addr e -> Off Word8 -> m e readByteOffAddr (Addr addr# b) (Off (I# off#)) = do - a <- prim (seq# (indexOffAddr# (addr# `plusAddr#` off#) 0#)) + a <- prim (readOffAddr# (addr# `plusAddr#` off#) 0#) a <$ touch b {-# INLINE readByteOffAddr #-} - readMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> m e -readMAddr maddr = readOffMAddr maddr 0 +readMAddr (MAddr addr# mb) = do + a <- prim (readOffAddr# addr# 0#) + a <$ touch mb {-# INLINE readMAddr #-} readOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m e @@ -498,17 +565,18 @@ {-# INLINE readByteOffMAddr #-} writeMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> e -> m () -writeMAddr maddr = writeOffMAddr maddr 0 +writeMAddr (MAddr addr# mb) e = + prim_ $ \s -> touch# mb (writeOffAddr# addr# 0# e s) {-# INLINE writeMAddr #-} writeOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> e -> m () -writeOffMAddr (MAddr addr# mb) (Off (I# off#)) a = - prim_ (writeOffAddr# addr# off# a) >> touch mb +writeOffMAddr (MAddr addr# mb) (Off (I# off#)) e = + prim_ $ \s -> touch# mb (writeOffAddr# addr# off# e s) {-# INLINE writeOffMAddr #-} writeByteOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off Word8 -> e -> m () writeByteOffMAddr (MAddr addr# mb) (Off (I# off#)) a = - prim_ (writeOffAddr# (addr# `plusAddr#` off#) 0# a) >> touch mb + prim_ $ \s -> touch# mb (writeOffAddr# (addr# `plusAddr#` off#) 0# a s) {-# INLINE writeByteOffMAddr #-} @@ -532,6 +600,95 @@ setMAddr (MAddr addr# mb) (Off (I# off#)) (Count (I# n#)) a = prim_ (setOffAddr# addr# off# n# a) >> touch mb {-# INLINE setMAddr #-} + + + +-- | Apply a pure function to the contents of a mutable variable. Returns the artifact of +-- computation. +-- +-- @since 0.2.0 +modifyMAddr :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> (a, b)) -> m b +modifyMAddr maddr f = modifyMAddrM maddr (return . f) +{-# INLINE modifyMAddr #-} + +-- | Apply a pure function to the contents of a mutable variable. +-- +-- @since 0.1.0 +modifyMAddr_ :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> a) -> m () +modifyMAddr_ maddr f = modifyMAddrM_ maddr (return . f) +{-# INLINE modifyMAddr_ #-} + + +-- | Apply a pure function to the contents of a mutable variable. Returns the old value. +-- +-- @since 2.0.0 +modifyFetchOldMAddr :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> a) -> m a +modifyFetchOldMAddr maddr f = modifyFetchOldMAddrM maddr (return . f) +{-# INLINE modifyFetchOldMAddr #-} + +-- | Apply a pure function to the contents of a mutable variable. Returns the new value. +-- +-- @since 2.0.0 +modifyFetchNewMAddr :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> a) -> m a +modifyFetchNewMAddr maddr f = modifyFetchNewMAddrM maddr (return . f) +{-# INLINE modifyFetchNewMAddr #-} + + +-- | Apply a monadic action to the contents of a mutable variable. Returns the artifact of +-- computation. +-- +-- @since 0.2.0 +modifyMAddrM :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> m (a, b)) -> m b +modifyMAddrM maddr f = do + a <- readMAddr maddr + (a', b) <- f a + b <$ writeMAddr maddr a' +{-# INLINE modifyMAddrM #-} + +-- | Apply a monadic action to the contents of a mutable variable. Returns the old value. +-- +-- @since 2.0.0 +modifyFetchOldMAddrM :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> m a) -> m a +modifyFetchOldMAddrM maddr f = do + a <- readMAddr maddr + a <$ (writeMAddr maddr =<< f a) +{-# INLINE modifyFetchOldMAddrM #-} + + +-- | Apply a monadic action to the contents of a mutable variable. Returns the new value. +-- +-- @since 2.0.0 +modifyFetchNewMAddrM :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> m a) -> m a +modifyFetchNewMAddrM maddr f = do + a <- readMAddr maddr + a' <- f a + a' <$ writeMAddr maddr a' +{-# INLINE modifyFetchNewMAddrM #-} + + +-- | Apply a monadic action to the contents of a mutable variable. +-- +-- @since 0.1.0 +modifyMAddrM_ :: (MonadPrim s m, Prim a) => MAddr a s -> (a -> m a) -> m () +modifyMAddrM_ maddr f = readMAddr maddr >>= f >>= writeMAddr maddr +{-# INLINE modifyMAddrM_ #-} + +-- | Swap contents of two mutable variables. Returns their old values. +-- +-- @since 0.1.0 +swapMAddrs :: (MonadPrim s m, Prim a) => MAddr a s -> MAddr a s -> m (a, a) +swapMAddrs maddr1 maddr2 = do + a1 <- readMAddr maddr1 + a2 <- modifyFetchOldMAddr maddr2 (const a1) + (a1, a2) <$ writeMAddr maddr1 a2 +{-# INLINE swapMAddrs #-} + +-- | Swap contents of two mutable variables. +-- +-- @since 0.1.0 +swapMAddrs_ :: (MonadPrim s m, Prim a) => MAddr a s -> MAddr a s -> m () +swapMAddrs_ maddr1 maddr2 = void $ swapMAddrs maddr1 maddr2 +{-# INLINE swapMAddrs_ #-} diff --git a/src/Data/Prim/Memory/ByteString.hs b/src/Data/Prim/Memory/ByteString.hs --- a/src/Data/Prim/Memory/ByteString.hs +++ b/src/Data/Prim/Memory/ByteString.hs @@ -40,6 +40,7 @@ import Data.Prim import Foreign.Prim import Control.Prim.Monad +import Control.Prim.Eval import GHC.ForeignPtr import Data.Prim.Memory.Ptr import Data.Prim.Memory.Bytes.Internal @@ -159,5 +160,5 @@ withNoHaltPtrByteString (PS (ForeignPtr addr'# ptrContents) (I# o#) _) f = do let addr# = addr'# `plusAddr#` o# #endif - withAliveUnliftPrim ptrContents $ f (Ptr addr#) + keepAlive ptrContents $ f (Ptr addr#) {-# INLINE withNoHaltPtrByteString #-} diff --git a/src/Data/Prim/Memory/Bytes.hs b/src/Data/Prim/Memory/Bytes.hs --- a/src/Data/Prim/Memory/Bytes.hs +++ b/src/Data/Prim/Memory/Bytes.hs @@ -16,8 +16,9 @@ -- Portability : non-portable -- module Data.Prim.Memory.Bytes - ( -- * Mutable - Bytes + ( module Data.Prim + -- * Mutable + , Bytes , toByteArray# , fromByteArray# , cloneBytes @@ -65,8 +66,9 @@ , allocPinnedMBytes , allocAlignedMBytes , allocUnpinnedMBytes - , callocMBytes - , callocAlignedMBytes + , allocZeroMBytes + , allocZeroPinnedMBytes + , allocZeroAlignedMBytes , shrinkMBytes , resizeMBytes , reallocMBytes @@ -103,9 +105,13 @@ , toForeignPtrBytes , toForeignPtrMBytes -- * Conversion + , toUArrayBytes + , fromUArrayBytes + , toUMArrayMBytes + , fromUMArrayMBytes , fromListBytes , fromListBytesN - , fromListBytesN_ + , fromListZeroBytesN_ , appendBytes , concatBytes , toListBytes @@ -146,7 +152,6 @@ , prefetchMBytes2 , prefetchBytes3 , prefetchMBytes3 - , module Data.Prim -- * Helpers ) where @@ -158,31 +163,8 @@ import Data.Prim.Memory.Internal import Foreign.Prim --- | Wrap `ByteArray#` into `Bytes` -toByteArray# :: Bytes p -> ByteArray# -toByteArray# (Bytes b#) = b# - --- | Unwrap `Bytes` to get the underlying `ByteArray#`. -fromByteArray# :: ByteArray# -> Bytes 'Inc -fromByteArray# = Bytes - --- | Wrap `MutableByteArray#` into `MBytes` -toMutableByteArray# :: MBytes p s -> MutableByteArray# s -toMutableByteArray# (MBytes mb#) = mb# - --- | Unwrap `MBytes` to get the underlying `MutableByteArray#`. -fromMutableByteArray# :: MutableByteArray# s -> MBytes 'Inc s -fromMutableByteArray# = MBytes - - - --- | Check if two mutable bytes pointers refer to the same memory -isSameMBytes :: MBytes p1 s -> MBytes p2 s -> Bool -isSameMBytes (MBytes mb1#) (MBytes mb2#) = isTrue# (sameMutableByteArray# mb1# mb2#) -{-# INLINE isSameMBytes #-} - eqBytes :: Bytes p1 -> Bytes p2 -> Bool -eqBytes b1 b2 = isSameBytes b1 b2 || eqMem b1 b2 +eqBytes b1 b2 = isSameBytes b1 b2 || eqByteMem b1 b2 {-# INLINE eqBytes #-} ---- Pure @@ -282,9 +264,9 @@ createBytesST_ n f = runST $ createBytes_ n f {-# INLINE createBytesST_ #-} -callocMBytes :: (MonadPrim s m, Prim e, Typeable p) => Count e -> m (MBytes p s) -callocMBytes n = allocMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0 -{-# INLINE callocMBytes #-} +allocZeroMBytes :: (MonadPrim s m, Prim e, Typeable p) => Count e -> m (MBytes p s) +allocZeroMBytes n = allocMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0 +{-# INLINE allocZeroMBytes #-} @@ -361,20 +343,22 @@ toListSlackBytes = toListSlackMem {-# INLINE toListSlackBytes #-} --- | Same as `loadListMem` +-- | Same as `loadListMutMem` loadListMBytes :: (Prim e, Typeable p, MonadPrim s m) => [e] -> MBytes p s -> m ([e], Count e) -loadListMBytes = loadListMem +loadListMBytes = loadListMutMem {-# INLINE loadListMBytes #-} --- | Same as `loadListMem_` +-- | Same as `loadListMutMem_` loadListMBytes_ :: (Prim e, Typeable p, MonadPrim s m) => [e] -> MBytes p s -> m () -loadListMBytes_ = loadListMem_ +loadListMBytes_ = loadListMutMem_ {-# INLINE loadListMBytes_ #-} -- | Same as `fromListZeroMemN_` -fromListBytesN_ :: (Prim e, Typeable p) => Count e -> [e] -> Bytes p -fromListBytesN_ = fromListZeroMemN_ -{-# INLINE fromListBytesN_ #-} +-- +-- @since 0.3.0 +fromListZeroBytesN_ :: (Prim e, Typeable p) => Count e -> [e] -> Bytes p +fromListZeroBytesN_ = fromListZeroMemN_ +{-# INLINE fromListZeroBytesN_ #-} -- | Exactly like `fromListMemN`, but restricted to `Bytes`. fromListBytesN :: @@ -449,7 +433,8 @@ -> e -- ^ Expected old value -> e -- ^ New value -> m e -casMBytes (MBytes mba#) (Off (I# i#)) expected new = prim $ casMutableByteArray# mba# i# expected new +casMBytes (MBytes mba#) (Off (I# i#)) expected new = + prim $ casMutableByteArray# mba# i# expected new {-# INLINE casMBytes #-} diff --git a/src/Data/Prim/Memory/Bytes/Internal.hs b/src/Data/Prim/Memory/Bytes/Internal.hs --- a/src/Data/Prim/Memory/Bytes/Internal.hs +++ b/src/Data/Prim/Memory/Bytes/Internal.hs @@ -21,8 +21,13 @@ ( Bytes(..) , MBytes(..) , Pinned(..) + , toByteArray# + , fromByteArray# + , toMutableByteArray# + , fromMutableByteArray# , isSameBytes , isSamePinnedBytes + , isSameMBytes , isPinnedBytes , isPinnedMBytes , castStateMBytes @@ -36,7 +41,8 @@ , allocPinnedMBytes , allocAlignedMBytes , allocUnpinnedMBytes - , callocAlignedMBytes + , allocZeroPinnedMBytes + , allocZeroAlignedMBytes , reallocMBytes , freezeMBytes , thawBytes @@ -56,6 +62,10 @@ , readByteOffMBytes , writeOffMBytes , writeByteOffMBytes + , toUArrayBytes + , fromUArrayBytes + , toUMArrayMBytes + , fromUMArrayMBytes , toPtrBytes , toPtrMBytes , withPtrBytes @@ -72,7 +82,9 @@ import Control.DeepSeq import Control.Prim.Monad import Control.Prim.Monad.Unsafe +import Control.Prim.Eval import Data.Prim +import Data.Prim.Array import Data.Prim.Class import Data.Typeable import Foreign.Prim @@ -132,7 +144,33 @@ rnf (MBytes _) = () +-- | Unwrap `Bytes` to get the underlying `ByteArray#`. +-- +-- @since 0.1.0 +toByteArray# :: Bytes p -> ByteArray# +toByteArray# (Bytes b#) = b# +-- | Wrap `ByteArray#` into `Bytes` +-- +-- @since 0.1.0 +fromByteArray# :: ByteArray# -> Bytes 'Inc +fromByteArray# = Bytes + +-- | Unwrap `MBytes` to get the underlying `MutableByteArray#`. +-- +-- @since 0.1.0 +toMutableByteArray# :: MBytes p s -> MutableByteArray# s +toMutableByteArray# (MBytes mb#) = mb# + +-- | Wrap `MutableByteArray#` into `MBytes` +-- +-- @since 0.1.0 +fromMutableByteArray# :: MutableByteArray# s -> MBytes 'Inc s +fromMutableByteArray# = MBytes + + + + ---- Pure compareByteOffBytes :: Prim e => Bytes p1 -> Off Word8 -> Bytes p2 -> Off Word8 -> Count e -> Ordering @@ -200,14 +238,24 @@ (# s', ba# #) -> (# s', MBytes ba# #) {-# INLINE allocAlignedMBytes #-} -callocAlignedMBytes :: + +-- @since 0.3.0 +allocZeroPinnedMBytes :: (MonadPrim s m, Prim e) => Count e -- ^ Size in number of bytes -> m (MBytes 'Pin s) -callocAlignedMBytes n = allocAlignedMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0 -{-# INLINE callocAlignedMBytes #-} +allocZeroPinnedMBytes n = allocPinnedMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0 +{-# INLINE allocZeroPinnedMBytes #-} +-- @since 0.3.0 +allocZeroAlignedMBytes :: + (MonadPrim s m, Prim e) + => Count e -- ^ Size in number of bytes + -> m (MBytes 'Pin s) +allocZeroAlignedMBytes n = allocAlignedMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0 +{-# INLINE allocZeroAlignedMBytes #-} + getByteCountMBytes :: MonadPrim s m => MBytes p s -> m (Count Word8) getByteCountMBytes (MBytes mba#) = prim $ \s -> @@ -362,6 +410,36 @@ {-# INLINE setMBytes #-} +-- | /O(1)/ - Cast an unboxed array into `Bytes` +-- +-- @since 0.3.0 +fromUArrayBytes :: UArray e -> Bytes 'Inc +fromUArrayBytes (UArray ba#) = fromByteArray# ba# +{-# INLINE fromUArrayBytes #-} + +-- | /O(1)/ - Cast `Bytes` into an unboxed array +-- +-- @since 0.3.0 +toUArrayBytes :: Bytes p -> UArray e +toUArrayBytes b = UArray (toByteArray# b) +{-# INLINE toUArrayBytes #-} + +-- | /O(1)/ - Cast a mutable unboxed array into `MBytes` +-- +-- @since 0.3.0 +fromUMArrayMBytes :: UMArray e s -> MBytes 'Inc s +fromUMArrayMBytes (UMArray a#) = fromMutableByteArray# a# +{-# INLINE fromUMArrayMBytes #-} + +-- | /O(1)/ - Cast `MBytes` into a mutable unboxed array +-- +-- @since 0.3.0 +toUMArrayMBytes :: MBytes p s -> UMArray e s +toUMArrayMBytes mb = UMArray (toMutableByteArray# mb) +{-# INLINE toUMArrayMBytes #-} + + + toPtrBytes :: Bytes 'Pin -> Ptr e toPtrBytes (Bytes ba#) = Ptr (byteArrayContents# ba#) {-# INLINE toPtrBytes #-} @@ -380,7 +458,7 @@ -- | Same as `withPtrBytes`, but is suitable for actions that don't terminate withNoHaltPtrBytes :: MonadUnliftPrim s m => Bytes 'Pin -> (Ptr e -> m b) -> m b -withNoHaltPtrBytes b f = withAliveUnliftPrim b $ f (toPtrBytes b) +withNoHaltPtrBytes b f = keepAlive b $ f (toPtrBytes b) {-# INLINE withNoHaltPtrBytes #-} withPtrMBytes :: MonadPrim s m => MBytes 'Pin s -> (Ptr e -> m b) -> m b @@ -390,7 +468,7 @@ {-# INLINE withPtrMBytes #-} withNoHaltPtrMBytes :: MonadUnliftPrim s m => MBytes 'Pin s -> (Ptr e -> m b) -> m b -withNoHaltPtrMBytes mb f = withAliveUnliftPrim mb $ f (toPtrMBytes mb) +withNoHaltPtrMBytes mb f = keepAlive mb $ f (toPtrMBytes mb) {-# INLINE withNoHaltPtrMBytes #-} toForeignPtrBytes :: Bytes 'Pin -> ForeignPtr e @@ -464,6 +542,13 @@ isSamePinnedBytes pb1 pb2 = toPtrBytes pb1 == toPtrBytes pb2 {-# INLINE isSamePinnedBytes #-} + +-- | Check if two mutable bytes pointers refer to the same memory +-- +-- @since 0.1.0 +isSameMBytes :: MBytes p1 s -> MBytes p2 s -> Bool +isSameMBytes (MBytes mb1#) (MBytes mb2#) = isTrue# (sameMutableByteArray# mb1# mb2#) +{-# INLINE isSameMBytes #-} byteStringConvertError :: String -> a diff --git a/src/Data/Prim/Memory/Fold.hs b/src/Data/Prim/Memory/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Fold.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Prim.Memory.Fold +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Memory.Fold where + +import Data.Prim +import Data.Prim.Memory.Internal + + +foldlMem :: + forall e a mr. (Prim e, MemRead mr) + => (a -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +foldlMem f = ifoldlMem (\a _ -> f a) +{-# INLINE foldlMem #-} + + +ifoldlMem :: + forall e a mr. (Prim e, MemRead mr) + => (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldlMem f initAcc mem = ifoldlOffMem 0 (countMem mem :: Count e) f initAcc mem +{-# INLINE ifoldlMem #-} + +ifoldlOffMem :: + forall e a mr. (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldlOffMem off count f initAcc mem = loop initAcc off + where + k = countToOff count + off + loop !acc i + | i >= k = acc + | otherwise = loop (f acc i (indexOffMem mem i)) (i + 1) +{-# INLINE ifoldlOffMem #-} + + + + +foldlLazyMem :: + forall e a mr. (Prim e, MemRead mr) + => (a -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +foldlLazyMem f = ifoldlLazyMem (\a _ -> f a) +{-# INLINE foldlLazyMem #-} + +ifoldlLazyMem :: + forall e a mr. (Prim e, MemRead mr) + => (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldlLazyMem f initAcc mem = ifoldlLazyOffMem 0 (countMem mem :: Count e) f initAcc mem +{-# INLINE ifoldlLazyMem #-} + +ifoldlLazyOffMem :: + forall e a mr. (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldlLazyOffMem off count f initAcc mem = loop initAcc off + where + k = countToOff count + off + loop acc i + | i >= k = acc + | otherwise = loop (f acc i (indexOffMem mem i)) (i + 1) +{-# INLINE ifoldlLazyOffMem #-} + + + + +foldrMem :: + forall e a mr. (Prim e, MemRead mr) + => (e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +foldrMem f = ifoldrMem (const f) +{-# INLINE foldrMem #-} + +ifoldrMem :: + forall e a mr. (Prim e, MemRead mr) + => (Off e -> e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldrMem f initAcc mem = ifoldrOffMem 0 (countMem mem :: Count e) f initAcc mem +{-# INLINE ifoldrMem #-} + +ifoldrOffMem :: + forall e a mr. (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (Off e -> e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldrOffMem off count f initAcc mem = loop initAcc off + where + k = countToOff count + off + loop !acc i + | i >= k = acc + | otherwise = f i (indexOffMem mem i) (loop acc (i + 1)) +{-# INLINE ifoldrOffMem #-} + + +-- | Right fold with a lazy accumulator +-- +-- @since 0.3.0 +foldrLazyMem :: + forall e a mr. (Prim e, MemRead mr) + => (e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +foldrLazyMem f = ifoldrLazyMem (const f) +{-# INLINE foldrLazyMem #-} + +-- | Right fold with a lazy accumulator using an offset aware function +-- +-- @since 0.3.0 +ifoldrLazyMem :: + forall e a mr. (Prim e, MemRead mr) + => (Off e -> e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldrLazyMem f initAcc mem = + ifoldrLazyOffMem 0 (countMem mem :: Count e) f initAcc mem +{-# INLINE ifoldrLazyMem #-} + + +ifoldrLazyOffMem :: + forall e a mr. (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (Off e -> e -> a -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldrLazyOffMem off count f initAcc mem = loop initAcc off + where + k = countToOff count + off + loop acc i + | i >= k = acc + | otherwise = f i (indexOffMem mem i) (loop acc (i + 1)) +{-# INLINE ifoldrLazyOffMem #-} + + + + +foldMapOffMem :: + forall e m mr. (Prim e, MemRead mr, Monoid m) + => Off e + -> Count e + -> (e -> m) + -> mr + -> m +foldMapOffMem off count f = ifoldrLazyOffMem off count (\_ e acc -> f e `mappend` acc) mempty +{-# INLINE foldMapOffMem #-} + +ifoldMapOffMem :: + forall e m mr. (Prim e, MemRead mr, Monoid m) + => Off e + -> Count e + -> (Off e -> e -> m) + -> mr + -> m +ifoldMapOffMem off count f = + ifoldrLazyOffMem off count (\i e acc -> f i e `mappend` acc) mempty +{-# INLINE ifoldMapOffMem #-} + + + +anyOffMem :: + forall e mr. (Prim e, MemRead mr) + => Off e + -> Count e + -> (e -> Bool) + -> mr + -> Bool +anyOffMem off count p = getAny #. foldMapOffMem off count (Any #. p) +{-# INLINE anyOffMem #-} + +ianyOffMem :: + forall e mr. (Prim e, MemRead mr) + => Off e + -> Count e + -> (Off e -> e -> Bool) + -> mr + -> Bool +ianyOffMem off count p = getAny #. ifoldMapOffMem off count (\i -> Any #. p i) +{-# INLINE ianyOffMem #-} + + +anyMem :: forall e mr . (Prim e, MemRead mr) => (e -> Bool) -> mr -> Bool +anyMem p xs = anyOffMem 0 (countMem xs :: Count e) p xs +{-# INLINE anyMem #-} + +ianyMem :: forall e mr . (Prim e, MemRead mr) => (Off e -> e -> Bool) -> mr -> Bool +ianyMem p xs = ianyOffMem 0 (countMem xs :: Count e) p xs +{-# INLINE ianyMem #-} + +allOffMem :: + forall e mr. (Prim e, MemRead mr) + => Off e + -> Count e + -> (e -> Bool) + -> mr + -> Bool +allOffMem off count p = getAll #. foldMapOffMem off count (All #. p) +{-# INLINE allOffMem #-} + +iallOffMem :: + forall e mr. (Prim e, MemRead mr) + => Off e + -> Count e + -> (Off e -> e -> Bool) + -> mr + -> Bool +iallOffMem off count p = getAll #. ifoldMapOffMem off count (\i -> All #. p i) +{-# INLINE iallOffMem #-} + + +allMem :: forall e mr . (Prim e, MemRead mr) => (e -> Bool) -> mr -> Bool +allMem p xs = allOffMem 0 (countMem xs :: Count e) p xs +{-# INLINE allMem #-} + +iallMem :: forall e mr . (Prim e, MemRead mr) => (Off e -> e -> Bool) -> mr -> Bool +iallMem p xs = iallOffMem 0 (countMem xs :: Count e) p xs +{-# INLINE iallMem #-} + + + +--------- + + + + +-- Dangerous: ignores the slack +eqMem :: forall e mr . (Prim e, Eq e, MemRead mr) => mr -> mr -> Bool +eqMem m1 m2 + | isSameMem m1 m2 = True + | otherwise = n == countMem m2 && eqOffMem m1 0 m2 0 n + where + n = countMem m1 :: Count e +{-# INLINE eqMem #-} + + + +-- | Check two regions of memory for equality using the `Eq` instance. It will return +-- `True` whenever both regions hold exactly the same elements and `False` as soon as the +-- first pair of mismatched elements is discovered in the two regions. It is safe for both +-- regions to refer to the same part of memory. +-- +-- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the +-- element count @memCount@ is violated the result is either unpredictable output or +-- failure with a segfault. +-- +-- @since 0.3.0 +eqOffMem :: + (Prim e, Eq e, MemRead mr1, MemRead mr2) + => mr1 -- ^ /memRead1/ - First region of memory + -> Off e + -- ^ /memOff1/ - Offset for @memRead1@ in number of elements + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff1 + -> mr2 -- ^ /memRead2/ - Second region of memory + -> Off e + -- ^ /memOff2/ - Offset for @memRead1@ in number of elements + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff2 + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to compare + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > offToCount memOff1 + memCount < countMem memRead1 + -- + -- > offToCount memOff2 + memCount < countMem memRead2 + -> Bool +eqOffMem m1 off1 m2 off2 count = loop off1 + where + doff = off2 - off1 + k = countToOff count + off1 + loop !i + | i < k = indexOffMem m1 i == indexOffMem m2 (i + doff) && loop (i + 1) + | otherwise = True +{-# INLINE[1] eqOffMem #-} + +eqOffMemBinary :: + forall e mr1 mr2. (Prim e, MemRead mr1, MemRead mr2) + => mr1 + -> Off e + -> mr2 + -> Off e + -> Count e + -> Bool +eqOffMemBinary m1 off1 m2 off2 count = + eqByteOffMem m1 (toByteOff off1) m2 (toByteOff off2) (toByteCount count) +{-# INLINE eqOffMemBinary #-} + +{-# RULES +"eqOffMem/Char" forall mr1 (off1 :: Off Char) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Word" forall mr1 (off1 :: Off Word) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Word8" eqOffMem = eqByteOffMem +"eqOffMem/Word16" forall mr1 (off1 :: Off Word16) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Word32" forall mr1 (off1 :: Off Word32) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Word64" forall mr1 (off1 :: Off Word64) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Int" forall mr1 (off1 :: Off Int) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Int8" forall mr1 (off1 :: Off Int8) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Int16" forall mr1 (off1 :: Off Int16) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Int32" forall mr1 (off1 :: Off Int32) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +"eqOffMem/Int64" forall mr1 (off1 :: Off Int64) . eqOffMem mr1 off1 = eqOffMemBinary mr1 off1 +#-} + +eqOffMutMem :: + forall e ma1 ma2 m s. (Prim e, Eq e, MonadPrim s m, MemWrite ma1, MemWrite ma2) + => ma1 s + -> Off e + -> ma2 s + -> Off e + -> Count e + -> m Bool +eqOffMutMem mm1 off1 mm2 off2 count = loop off1 + where + doff = off2 - off1 + k = countToOff count + off1 + loop !i + | i < k = do + e1 <- readOffMutMem mm1 i + e2 <- readOffMutMem mm2 (i + doff) + if e1 == e2 + then loop (i + 1) + else pure False + | otherwise = pure True +{-# INLINE eqOffMutMem #-} + + +-- | Compare two mutable memory regions for element equality. Regions themselves are not +-- modified, as such it is semantically similar to `eqMem` which works on immutable +-- regions. +eqMutMem :: + forall e ma m s. (Prim e, Eq e, MonadPrim s m, MemAlloc ma) + => ma s + -> ma s + -> m Bool +eqMutMem mm1 mm2 + | isSameMutMem mm1 mm2 = pure True + | otherwise = do + n1 <- getCountMutMem mm1 + n2 <- getCountMutMem mm2 + if n1 /= n2 + then pure False + else eqOffMutMem mm1 0 mm2 0 (n1 :: Count e) +{-# INLINE eqMutMem #-} + + + +-- | Compare two regions using the `Ord` instance. It will return `EQ` whenever both +-- regions hold exactly the same elements and `LT` or `GT` as soon as the first discovered +-- element that is less than or greater than respectfully in the first region when +-- compared to the second one. It is safe for both regions to refer to the same part of +-- memory. +-- +-- @since 0.3.0 +compareMem :: + forall e mr. (Prim e, Ord e, MemRead mr) + => mr -- ^ /memRead1/ - First region of memory + -> mr -- ^ /memRead2/ - Second region of memory + -> Ordering +compareMem m1 m2 + | isSameMem m1 m2 = EQ + | otherwise = compareOffMem m1 0 m2 0 (min n1 n2) <> compare n1 n2 + where + n1 = countMem m1 :: Count e + n2 = countMem m2 :: Count e +{-# INLINE compareMem #-} + +-- | Compare two regions using the `Ord` instance. It will return `EQ` whenever both +-- regions hold exactly the same elements and `LT` or `GT` as soon as the first discovered +-- element that is less than or greater than respectfully in the first region when +-- compared to the second one. It is safe for both regions to refer to the same part of +-- memory. +-- +-- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the +-- element count @memCount@ is violated the result is either unpredictable output or +-- failure with a segfault. +-- +-- @since 0.3.0 +compareOffMem :: + (Prim e, Ord e, MemRead mr1, MemRead mr2) + => mr1 -- ^ /memRead1/ - First region of memory + -> Off e + -- ^ /memOff1/ - Offset for @memRead1@ in number of elements + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff1 + -> mr2 -- ^ /memRead2/ - Second region of memory + -> Off e + -- ^ /memOff2/ - Offset for @memRead1@ in number of elements + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff2 + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to compare + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > offToCount memOff1 + memCount < countMem memRead1 + -- + -- > offToCount memOff2 + memCount < countMem memRead2 + -> Ordering +compareOffMem m1 off1 m2 off2 count = loop off1 + where + doff = off2 - off1 + k = countToOff count + off1 + kRem = countToOff count `rem` 4 + k4 = k - kRem + -- Some loop unrolling to get an extra 25% kick for smaller types + loop !i + | i < k4 = + let !i' = i + 1 + !i'' = i + 2 + !i''' = i + 3 + in compare (indexOffMem m1 i) (indexOffMem m2 (i + doff)) <> + compare (indexOffMem m1 i') (indexOffMem m2 (i' + doff)) <> + compare (indexOffMem m1 i'') (indexOffMem m2 (i'' + doff)) <> + compare (indexOffMem m1 i''') (indexOffMem m2 (i''' + doff)) <> + loop (i + 4) + | i < k = compare (indexOffMem m1 i) (indexOffMem m2 (i + doff)) <> loop (i + 1) + | otherwise = EQ +{-# INLINE [1] compareOffMem #-} + +{-# RULES +"compareOffMem/Word8" compareOffMem = compareByteOffMem +#-} diff --git a/src/Data/Prim/Memory/ForeignPtr.hs b/src/Data/Prim/Memory/ForeignPtr.hs --- a/src/Data/Prim/Memory/ForeignPtr.hs +++ b/src/Data/Prim/Memory/ForeignPtr.hs @@ -61,6 +61,7 @@ ) where import Control.Prim.Monad +import Control.Prim.Eval import Data.Prim import Data.Prim.Class import Data.Prim.Memory.Bytes.Internal (Bytes, MBytes(..), Pinned(..), @@ -96,7 +97,7 @@ withNoHaltPtrAccess p action = toForeignPtr p >>= (`withNoHaltForeignPtr` action) {-# INLINE withNoHaltPtrAccess #-} -instance PtrAccess s (ForeignPtr a) where +instance PtrAccess RealWorld (ForeignPtr a) where toForeignPtr = pure . coerce {-# INLINE toForeignPtr #-} @@ -135,6 +136,7 @@ {-# INLINE withNoHaltPtrAccess #-} + -- | Apply an action to the raw pointer. It is unsafe to return the actual pointer back from -- the action because memory itself might get garbage collected or cleaned up by -- finalizers. @@ -156,7 +158,7 @@ withNoHaltForeignPtr :: MonadUnliftPrim s m => ForeignPtr e -> (Ptr e -> m b) -> m b withNoHaltForeignPtr (ForeignPtr addr# ptrContents) f = - withAliveUnliftPrim ptrContents $ f (Ptr addr#) + keepAlive ptrContents $ f (Ptr addr#) {-# INLINE withNoHaltForeignPtr #-} -- | Lifted version of `GHC.touchForeignPtr`. @@ -272,13 +274,13 @@ -- | Unlifted version of `GHC.newConcForeignPtr` newConcForeignPtr :: MonadUnliftPrim RW m => Ptr e -> m () -> m (ForeignPtr e) newConcForeignPtr ptr fin = - withRunInPrimBase $ \run -> liftPrimBase (GHC.newConcForeignPtr ptr (run fin)) + withRunInIO $ \run -> liftPrimBase (GHC.newConcForeignPtr ptr (run fin)) -- | Unlifted version of `GHC.addForeignPtrConcFinalizer` addForeignPtrConcFinalizer :: MonadUnliftPrim RW m => ForeignPtr a -> m () -> m () addForeignPtrConcFinalizer fp fin = - withRunInPrimBase $ \run -> liftPrimBase (GHC.addForeignPtrConcFinalizer fp (run fin)) + withRunInIO $ \run -> liftPrimBase (GHC.addForeignPtrConcFinalizer fp (run fin)) -- | Lifted version of `GHC.finalizeForeignPtr`. finalizeForeignPtr :: MonadPrim RW m => ForeignPtr e -> m () diff --git a/src/Data/Prim/Memory/Internal.hs b/src/Data/Prim/Memory/Internal.hs --- a/src/Data/Prim/Memory/Internal.hs +++ b/src/Data/Prim/Memory/Internal.hs @@ -23,2335 +23,2794 @@ , module Data.Prim.Memory.Bytes.Internal ) where -import Control.Exception -import Control.Monad.ST -import Control.Prim.Monad -import Control.Prim.Monad.Unsafe -import qualified Data.ByteString as BS -import Data.Foldable as Foldable -import Data.Kind -import Data.List as List -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Monoid as Monoid -import Data.Prim -import Data.Prim.Memory.Bytes.Internal -import Data.Prim.Memory.ByteString -import Data.Prim.Memory.ForeignPtr -import Data.Prim.Memory.Ptr -import qualified Data.Semigroup as Semigroup -import qualified Data.Prim.Memory.Text as T -import Foreign.Prim -import Numeric (showHex) - --- | Type class that can be implemented for an immutable data type that provides --- read-only direct access to memory -class MemRead mr where - - -- | Number of bytes allocated by the data type available for reading. - -- - -- ====__Example__ - -- - -- >>> :set -XDataKinds - -- >>> import Data.Prim.Memory - -- >>> byteCountMem (fromByteListMem [1,2,3] :: Bytes 'Inc) - -- Count {unCount = 3} - -- - -- @since 0.1.0 - byteCountMem :: mr -> Count Word8 - - -- | Read an element with an offset in number of elements, rather than bytes as is the - -- case with `indexByteOffMem`. - -- - -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the - -- result is either unpredictable output or failure with a segfault. - -- - -- @since 0.1.0 - indexOffMem :: Prim e - => mr -- ^ /memRead/ - Memory to read an element from - -> Off e - -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= off - -- - -- > unOffBytes off <= unCount (byteCountMem memRead - byteCountType @e) - -- - -> e - indexOffMem mr off = indexByteOffMem mr (toByteOff off) - {-# INLINE indexOffMem #-} - - -- | Read an element with an offset in number of bytes. Bounds are not checked. - -- - -- [Unsafe] When precondition for @off@ argument is violated the result is either - -- unpredictable output or failure with a segfault. - -- - -- @since 0.1.0 - indexByteOffMem :: Prim e - => mr -- ^ /memRead/ - Memory to read an element from - -> Off Word8 - -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= unOff off - -- - -- > unOff off <= unCount (byteCountMem memRead - byteCountType @e) - -- - -> e - - -- | Copy contiguous chunk of memory from the read only memory into the target mutable - -- `MBytes`. Source and target /must not/ refer to the same memory region, otherwise - -- that would imply that the source is not immutable which would be a violation of some - -- other invariant elsewhere in the code. - -- - -- [Unsafe] When a precondition for either of the offsets @memSourceOff@, @memTargetOff@ - -- or the element count @memCount@ is violated the result is either unpredictable output or - -- failure with a segfault. - -- - -- @since 0.1.0 - copyByteOffToMBytesMem :: - (MonadPrim s m, Prim e) - => mr -- ^ /memSourceRead/ - Source from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset into source memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) - -> MBytes p s -- ^ /memTargetWrite/ - Target mutable memory - -> Off Word8 - -- ^ /memTargetOff/ - Offset into target memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- > unOff memTargetOff <= unCount (byteCountMem memTargetWrite - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- > unCountBytes memCount + unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) - -- - -- > unCountBytes memCount + unOff memTargetOff <= unCount (byteCountMem memTargetRead - byteCountType @e) - -> m () - - -- | Copy contiguous chunk of memory from the read only memory into the target mutable - -- `Ptr`. Source and target /must not/ refer to the same memory region, otherwise that - -- would imply that the source is not immutable which would be a violation of some other - -- invariant elsewhere in the code. - -- - -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ - -- or the element count @memCount@ is violated a call to this function can result in: - -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with - -- a segfault. - -- - -- - -- @since 0.1.0 - copyByteOffToPtrMem :: - (MonadPrim s m, Prim e) - => mr -- ^ /memSourceRead/ - Source from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset into source memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) - -> Ptr e - -- ^ /memTargetWrite/ - Pointer to the target mutable memory - -- - -- /__Preconditions:__/ - -- - -- Once the pointer is advanced by @memTargetOff@ the next @unCountBytes memCount@ bytes must - -- still belong to the same region of memory @memTargetWrite@ - -> Off Word8 - -- ^ /memTargetOff/ - Number of bytes to advance the pointer @memTargetWrite@ forward - -- - -- /__Precondition:__/ - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same - -- memory region @memTargetWrite@ - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- > unCountBytes memCount + unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) - -> m () - - -- | Same as `compareByteOffMem`, but compare the read-only - -- memory region to a region addressed by a `Ptr` inside of a `MonadPrim`. - -- - -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@, the - -- pointer @memRead2@ or the element count @memCount@ is violated the result is either - -- unpredictable output or failure with a segfault. - -- - -- @since 0.1.0 - compareByteOffToPtrMem :: - (MonadPrim s m, Prim e) - => mr -- ^ /memRead1/ - First memory region - -> Off Word8 - -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memOff1 - -- - -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -> Ptr e - -- ^ /memRead2/- Second memory region that can be accessed by a pointer - -- - -- /__Preconditions__/ - -- - -- Once the pointer is advanced by @memOff2@ the next @unCountBytes memCount@ bytes must - -- still belong to the same region of memory @memRead2@ - -> Off Word8 - -- ^ /memOff2/ - Number of bytes to advance the pointer @memRead2@ forward - -- - -- /__Precondition:__/ - -- - -- Once the pointer is advanced by @memOff2@ it must still refer to the same memory - -- region @memRead2@ - -> Count e -- ^ /memCount/ - Number of elements of type @e@ to compare as binary - -- ^ /memCount/ - Number of elements of type @e@ to compare as binary - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -> m Ordering - - -- | Same as `compareByteOffMem`, but compare the read-only memory region to `Bytes`. - -- - -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the - -- element count @memCount@ is violated the result is either unpredictable output or - -- failure with a segfault. - -- - -- @since 0.1.0 - compareByteOffToBytesMem :: - Prim e - => mr -- ^ /memRead1/ - First memory region - -> Off Word8 - -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memOff1 - -- - -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -> Bytes p -- ^ /memRead2/- Second memory region that is backed by `Bytes` - -> Off Word8 - -- ^ /memOff2/ - Offset for @memRead2@ in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memOff2 - -- - -- > unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to compare as binary - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -- - -- > unCountBytes memCount + unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) - -> Ordering - - -- | Compare two read-only regions of memory byte-by-byte. The very first mismatched - -- byte will cause this function to produce `LT` if the byte in @memRead1@ is smaller - -- than the one in @memRead2@ and `GT` if it is bigger. It is not a requirement to - -- short-circuit on the first mismatch, but it is a good optimization to have for - -- non-sensitive data. Memory regions that store security critical data may choose to - -- implement this function to work in constant time. - -- - -- This function is usually implemented by either one of `compareByteOffToPtrMem` or - -- `compareByteOffToBytesMem`, depending on the nature of @mr@ type. However it differs - -- from the aforementioned functions with a fact that it is pure non-monadic - -- computation. - -- - -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the - -- element count @memCount@ is violated the result is either unpredictable output or - -- failure with a segfault. - -- - -- @since 0.1.0 - compareByteOffMem :: - (MemRead mr', Prim e) - => mr' -- ^ /memRead1/ - First memory region - -> Off Word8 - -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memOff1 - -- - -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -> mr -- ^ /memRead2/ - Second memory region - -> Off Word8 - -- ^ /memOff2/ - Offset for @memRead2@ in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memOff2 - -- - -- > unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to compare as binary - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) - -- - -- > unCountBytes memCount + unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) - -> Ordering - --- | Type class that can be implemented for a mutable data type that provides direct read --- and write access to memory -class MemWrite mw where - -- | Read an element with an offset in number of elements, rather than bytes as it is - -- the case with `readByteOffMem`. - -- - -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the - -- result is either unpredictable output or failure with a segfault. - -- - -- @since 0.1.0 - readOffMem :: (MonadPrim s m, Prim e) - => mw s -- ^ /memRead/ - Memory region to read an element from - -> Off e - -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= off - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > count <- getByteCountMem memRead - -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) - -- - -> m e - readOffMem mw off = readByteOffMem mw (toByteOff off) - {-# INLINE readOffMem #-} - - -- | Read an element with an offset in number of bytes. - -- - -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the - -- result is either unpredictable output or failure with a segfault. - -- - -- @since 0.1.0 - readByteOffMem :: (MonadPrim s m, Prim e) - => mw s -- ^ /memRead/ - Memory region to read an element from - -> Off Word8 - -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= off - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > count <- getByteCountMem memRead - -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) - -- - -> m e - - -- | Write an element with an offset in number of elements, rather than bytes as it is - -- the case with `writeByteOffMem`. - -- - -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the - -- outcome is either heap corruption or failure with a segfault. - -- - -- @since 0.1.0 - writeOffMem :: (MonadPrim s m, Prim e) - => mw s -- ^ /memWrite/ - Memory region to write an element into - -> Off e - -- ^ /off/ - Offset in number of elements from the beginning of @memWrite@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= off - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > count <- getByteCountMem memWrite - -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) - -- - -> e -- ^ /elt/ - Element to write - -> m () - writeOffMem mw off = writeByteOffMem mw (toByteOff off) - {-# INLINE writeOffMem #-} - - -- | Write an element with an offset in number of bytes. - -- - -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the - -- outcome is either heap corruption or failure with a segfault. - -- - -- @since 0.1.0 - writeByteOffMem :: (MonadPrim s m, Prim e) - => mw s -- ^ /memWrite/ - Memory region to write an element into - -> Off Word8 - -- ^ /off/ - Offset in number of elements from the beginning of @memWrite@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= off - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > count <- getByteCountMem memWrite - -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) - -- - -> e -> m () - - -- | Copy contiguous chunk of memory from the source mutable memory into the target - -- mutable `MBytes`. Source and target /may/ refer to overlapping memory regions. - -- - -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ - -- or the element count @memCount@ is violated a call to this function can result in: - -- copy of data that doesn't belong to @memSource@, heap corruption or failure with - -- a segfault. - -- - -- @since 0.1.0 - moveByteOffToMBytesMem :: - (MonadPrim s m, Prim e) - => mw s -- ^ /memSource/ - Source memory from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset in number of bytes into source memory - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOff (toByteOff memSourceOff) <= unCount (sourceByteCount - byteCountType @e) - -> MBytes p s -- ^ /memTarget/ - Target memory into where to copy - -> Off Word8 - -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Both source and target memory regions must have enough memory to perform a copy - -- of @memCount@ elements starting at their respective offsets. For types that also - -- implement `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) - -> m () - - -- | Copy contiguous chunk of memory from the source mutable memory into the target - -- `Ptr`. Source and target /may/ refer to overlapping memory regions. - -- - -- [Unsafe] When any precondition for one of the offsets @memSourceOff@ or - -- @memTargetOff@, a target pointer @memTarget@ or the element count @memCount@ is - -- violated a call to this function can result in: copy of data that doesn't belong to - -- @memSource@, heap corruption or failure with a segfault. - -- - -- @since 0.1.0 - moveByteOffToPtrMem :: - (MonadPrim s m, Prim e) - => mw s -- ^ /memSource/ - Source memory from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset in number of bytes into source memory - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOff (toByteOff memSourceOff) <= unCount (sourceByteCount - byteCountType @e) - -> Ptr e - -- ^ /memTarget/ - Target memory into where to copy - -- - -- /__Precondition:__/ - -- - -- Once the pointer is advanced by @memTargetOff@ the next @unCountBytes memCount@ bytes must - -- still belong to the same region of memory @memTargetWrite@ - -> Off Word8 - -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same - -- memory region @memTarget@ - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Both source and target memory regions must have enough memory to perform a copy - -- of @memCount@ elements starting at their respective offsets. For /memSource/ that also - -- implements `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) - -> m () - - -- | Copy contiguous chunk of memory from the read only memory region into the target - -- mutable memory region. Source and target /must not/ refer to the same memory region, - -- otherwise that would imply that the source is not immutable which would be a - -- violation of some other invariant elsewhere in the code. - -- - -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ - -- or the element count @memCount@ is violated a call to this function can result in: - -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with - -- a segfault. - -- - -- @since 0.1.0 - copyByteOffMem :: (MonadPrim s m, MemRead mr, Prim e) - => mr -- ^ /memSourceRead/ - Read-only source memory region from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset into source memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) - -> mw s -- ^ /memTargetWrite/ - Target mutable memory - -> Off Word8 - -- ^ /memTargetOff/ - Offset into target memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTargetWrite - -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Both source and target memory regions must have enough memory to perform a copy - -- of @memCount@ elements starting at their respective offsets. For @memSourceRead@: - -- - -- > unOff memSourceOff + unCountBytes memCount <= unCount (byteCountMem memSourceRead - byteCountType @e) - -- - -- and for @memTargetWrite@ that also implements `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTargetWrite - -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) - -> m () - - -- | Copy contiguous chunk of memory from a mutable memory region into the target - -- mutable memory region. Source and target /may/ refer to the same memory region. - -- - -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ - -- or the element count @memCount@ is violated a call to this function can result in: - -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with - -- a segfault. - -- - -- @since 0.1.0 - moveByteOffMem :: (MonadPrim s m, MemWrite mw', Prim e) - => mw' s -- ^ /memSource/ - Source memory from where to copy - -> Off Word8 - -- ^ /memSourceOff/ - Offset in number of bytes into source memory - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOffBytes memSourceOff <= unCount (sourceByteCount - byteCountType @e) - -> mw s -- ^ /memTarget/ - Target memory into where to copy - -> Off Word8 - -- ^ /memTargetOff/ - Offset into target memory in number of bytes - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOffBytes (toByteOff memTargetOff) <= unCount (targetByteCount - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Both source and target memory regions must have enough memory to perform a copy - -- of @memCount@ elements starting at their respective offsets. For types that also - -- implement `MemAlloc` this can be described as: - -- - -- > sourceByteCount <- getByteCountMem memSource - -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) - -> m () - - -- TODO: Potential feature for the future implementation. Will require extra function in `Prim`. - --setByteOffMem :: (MonadPrim s m, Prim e) => w s -> Off Word8 -> Count e -> e -> m () - - -- | Write the same value @memCount@ times into each cell of @memTarget@ starting at an - -- offset @memTargetOff@. - -- - -- [Unsafe] Bounds are not checked. When precondition for @memTargetOff@ argument is - -- violated the outcome is either heap corruption or failure with a segfault. - -- - -- @since 0.1.0 - setMem - :: (MonadPrim s m, Prim e) - => mw s -- ^ /memTarget/ - Target memory into where to write the element - -> Off e - -- ^ /memTargetOff/ - Offset into target memory in number of elements at which element - -- setting should start. - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> Count e - -- ^ /memCount/ - Number of times the element @elt@ should be written - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Target memory region should have enough memory to perform a set operation of the - -- supplied element @memCount@ number of times starting at the supplied offset. For - -- types that also implement `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unCountBytes memCount + unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> e - -- ^ /elt/ - Element to write into memory cells. This function is strict with - -- respect to element, which means that the even @memCount = 0@ it might be still - -- fully evaluated. - -> m () - --- | Generalized memory allocation and pure/mutable state conversion. -class (MemRead (FrozenMem ma), MemWrite ma) => MemAlloc ma where - -- | Memory region in the immutable state. Types for frozen and thawed states of - -- memory region are in one-to-one correspondence, therefore @ma <-> FrozeMem ma@ will - -- always uniquely identify each other, which is an extremely useful property when it - -- comes to type inference. - type FrozenMem ma = (fm :: Type) | fm -> ma - - -- | Extract from the mutable memory region information about how many bytes it can hold. - -- - -- @since 0.1.0 - getByteCountMem :: MonadPrim s m => ma s -> m (Count Word8) - - -- | Allocate a mutable memory region for specified number of elements. Memory is not - -- reset and will likely hold some garbage data, therefore prefer to use `allocZeroMem`, - -- unless it is guaranteed that all of allocated memory will be overwritten. - -- - -- [Unsafe] When precondition for @memCount@ argument is violated the outcome is - -- upredictable. One possible outcome is termination with - -- `Control.Exception.HeapOverflow` async exception. In a pure setting, such as when - -- executed within `runST`, if memory is not fully overwritten it can result in - -- violation of referential transparency, because content of newly allocated - -- region is non-determinstic. - -- - -- @since 0.1.0 - allocMem :: (Prim e, MonadPrim s m) - => Count e - -- ^ /memCount/ - Number of elements to allocate. - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Possibility of overflow: - -- - -- > unCount memCount <= fromByteCount @e (Count maxBound) - -- - -- When converted to bytes the value should be less then available physical memory - -> m (ma s) - - -- | Convert the state of an immutable memory region to the mutable one. This is a no - -- copy operation, as such it is fast, but dangerous. See `thawCopyMem` for a safe alternative. - -- - -- [Unsafe] It makes it possible to break referential transparency, because any - -- subsequent destructive operation to the mutable region of memory will also be - -- reflected in the frozen immutable type as well. - -- - -- @since 0.1.0 - thawMem :: MonadPrim s m => FrozenMem ma -> m (ma s) - - -- | Convert the state of a mutable memory region to the immutable one. This is a no - -- copy operation, as such it is fast, but dangerous. See `freezeCopyMem` for a safe alternative. - -- - -- [Unsafe] It makes it possible to break referential transparency, because any - -- subsequent destructive operation to the mutable region of memory will also be - -- reflected in the frozen immutable type as well. - -- - -- @since 0.1.0 - freezeMem :: MonadPrim s m => ma s -> m (FrozenMem ma) - - -- | Either grow or shrink currently allocated mutable region of memory. For some - -- implementations it might be possible to change the size of the allocated region - -- in-place, i.e. without copy. However in all implementations there is a good chance - -- that the memory region has to be allocated anew, in which case all of the contents - -- up to the minimum of new and old sizes will get copied over. After the resize - -- operation is complete the supplied @memSource@ region must not be used - -- anymore. Moreover, no reference to the old one should be kept in order to allow - -- garbage collection of the original in case a new one had to be allocated. - -- - -- [Unsafe] Undefined behavior when @memSource@ is used afterwards. The same unsafety - -- notice from `allocMem` with regards to @memCount@ is applcable here as well. - -- - -- @since 0.1.0 - resizeMem :: (MonadPrim s m, Prim e) - => ma s - -- ^ /memSource/ - Source memory region to resize - -> Count e - -- ^ /memCount/ - Number of elements for the reallocated memory region - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Should be less then available physical memory - -> m (ma s) - resizeMem = defaultResizeMem - {-# INLINE resizeMem #-} - - -instance MemRead ByteString where - byteCountMem = Count . BS.length - {-# INLINE byteCountMem #-} - indexOffMem bs i = unsafeInlineIO $ withPtrAccess bs (`readOffPtr` i) - {-# INLINE indexOffMem #-} - indexByteOffMem bs i = unsafeInlineIO $ withPtrAccess bs (`readByteOffPtr` i) - {-# INLINE indexByteOffMem #-} - copyByteOffToMBytesMem bs srcOff mb dstOff c = - withPtrAccess bs $ \srcPtr -> copyByteOffPtrToMBytes srcPtr srcOff mb dstOff c - {-# INLINE copyByteOffToMBytesMem #-} - copyByteOffToPtrMem bs srcOff dstPtr dstOff c = - withPtrAccess bs $ \srcPtr -> copyByteOffPtrToPtr srcPtr srcOff dstPtr dstOff c - {-# INLINE copyByteOffToPtrMem #-} - compareByteOffToPtrMem bs off1 ptr2 off2 c = - withPtrAccess bs $ \ptr1 -> pure $! compareByteOffPtrToPtr ptr1 off1 ptr2 off2 c - {-# INLINE compareByteOffToPtrMem #-} - compareByteOffToBytesMem bs off1 bytes off2 c = - unsafeInlineIO $ withPtrAccess bs $ \ptr1 -> - pure $! compareByteOffPtrToBytes ptr1 off1 bytes off2 c - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem1 off1 bs off2 c = - unsafeInlineIO $ withPtrAccess bs $ \ptr2 -> compareByteOffToPtrMem mem1 off1 ptr2 off2 c - {-# INLINE compareByteOffMem #-} - - -instance MemAlloc MByteString where - type FrozenMem MByteString = ByteString - getByteCountMem (MByteString bs) = pure $! Count (BS.length bs) - {-# INLINE getByteCountMem #-} - allocMem c = do - let cb = toByteCount c - fp <- mallocByteCountPlainForeignPtr cb - pure $ MByteString (PS fp 0 (coerce cb)) - {-# INLINE allocMem #-} - thawMem bs = pure $ MByteString bs - {-# INLINE thawMem #-} - freezeMem (MByteString bs) = pure bs - {-# INLINE freezeMem #-} - resizeMem bsm@(MByteString (PS fp o n)) newc - | newn > n = defaultResizeMem bsm newc - | otherwise = pure $ MByteString (PS fp o newn) - where -- constant time slice if we need to reduce the size - Count newn = toByteCount newc - {-# INLINE resizeMem #-} - -instance MemWrite MByteString where - readOffMem (MByteString mbs) i = withPtrAccess mbs (`readOffPtr` i) - {-# INLINE readOffMem #-} - readByteOffMem (MByteString mbs) i = withPtrAccess mbs (`readByteOffPtr` i) - {-# INLINE readByteOffMem #-} - writeOffMem (MByteString mbs) i a = withPtrAccess mbs $ \ptr -> writeOffPtr ptr i a - {-# INLINE writeOffMem #-} - writeByteOffMem (MByteString mbs) i a = withPtrAccess mbs $ \ptr -> writeByteOffPtr ptr i a - {-# INLINE writeByteOffMem #-} - moveByteOffToPtrMem (MByteString fsrc) srcOff dstPtr dstOff c = - withPtrAccess fsrc $ \srcPtr -> moveByteOffPtrToPtr srcPtr srcOff dstPtr dstOff c - {-# INLINE moveByteOffToPtrMem #-} - moveByteOffToMBytesMem (MByteString fsrc) srcOff dst dstOff c = - withPtrAccess fsrc $ \srcPtr -> moveByteOffPtrToMBytes srcPtr srcOff dst dstOff c - {-# INLINE moveByteOffToMBytesMem #-} - copyByteOffMem src srcOff (MByteString fdst) dstOff c = - withPtrAccess fdst $ \dstPtr -> copyByteOffToPtrMem src srcOff dstPtr dstOff c - {-# INLINE copyByteOffMem #-} - moveByteOffMem src srcOff (MByteString fdst) dstOff c = - withPtrAccess fdst $ \dstPtr -> moveByteOffToPtrMem src srcOff dstPtr dstOff c - {-# INLINE moveByteOffMem #-} - setMem (MByteString mbs) off c a = withPtrAccess mbs $ \ptr -> setOffPtr ptr off c a - {-# INLINE setMem #-} - -instance MemRead T.Array where - byteCountMem = byteCountMem . T.toBytesArray - {-# INLINE byteCountMem #-} - indexOffMem a = indexOffMem (T.toBytesArray a) - {-# INLINE indexOffMem #-} - indexByteOffMem a = indexByteOffMem (T.toBytesArray a) - {-# INLINE indexByteOffMem #-} - copyByteOffToMBytesMem a = copyByteOffToMBytesMem (T.toBytesArray a) - {-# INLINE copyByteOffToMBytesMem #-} - copyByteOffToPtrMem a = copyByteOffToPtrMem (T.toBytesArray a) - {-# INLINE copyByteOffToPtrMem #-} - compareByteOffToPtrMem a = compareByteOffToPtrMem (T.toBytesArray a) - {-# INLINE compareByteOffToPtrMem #-} - compareByteOffToBytesMem a = compareByteOffToBytesMem (T.toBytesArray a) - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem off1 a = compareByteOffMem mem off1 (T.toBytesArray a) - {-# INLINE compareByteOffMem #-} - -instance MemAlloc T.MArray where - type FrozenMem T.MArray = T.Array - getByteCountMem = getByteCountMBytes . T.toMBytesMArray - {-# INLINE getByteCountMem #-} - allocMem = fmap T.fromMBytesMArray . allocUnpinnedMBytes - {-# INLINE allocMem #-} - thawMem = fmap T.fromMBytesMArray . thawBytes . T.toBytesArray - {-# INLINE thawMem #-} - freezeMem = fmap T.fromBytesArray . freezeMBytes . T.toMBytesMArray - {-# INLINE freezeMem #-} - resizeMem m = fmap T.fromMBytesMArray . reallocMBytes (T.toMBytesMArray m) - {-# INLINE resizeMem #-} - -instance MemWrite T.MArray where - readOffMem m = readOffMBytes (T.toMBytesMArray m) - {-# INLINE readOffMem #-} - readByteOffMem m = readByteOffMBytes (T.toMBytesMArray m) - {-# INLINE readByteOffMem #-} - writeOffMem m = writeOffMBytes (T.toMBytesMArray m) - {-# INLINE writeOffMem #-} - writeByteOffMem m = writeByteOffMBytes (T.toMBytesMArray m) - {-# INLINE writeByteOffMem #-} - moveByteOffToPtrMem m = moveByteOffMBytesToPtr (T.toMBytesMArray m) - {-# INLINE moveByteOffToPtrMem #-} - moveByteOffToMBytesMem m = moveByteOffMBytesToMBytes (T.toMBytesMArray m) - {-# INLINE moveByteOffToMBytesMem #-} - moveByteOffMem src srcOff m = moveByteOffToMBytesMem src srcOff (T.toMBytesMArray m) - {-# INLINE moveByteOffMem #-} - copyByteOffMem src srcOff m = copyByteOffToMBytesMem src srcOff (T.toMBytesMArray m) - {-# INLINE copyByteOffMem #-} - setMem m = setMBytes (T.toMBytesMArray m) - {-# INLINE setMem #-} - -instance MemRead T.Text where - byteCountMem (T.Text _ _ n) = toByteCount (Count n :: Count Word16) - {-# INLINE byteCountMem #-} - indexByteOffMem (T.Text a o _) i = indexByteOffMem a (toByteOff (Off o :: Off Word16) + i) - {-# INLINE indexByteOffMem #-} - copyByteOffToMBytesMem (T.Text a o _) i = - copyByteOffToMBytesMem a (toByteOff (Off o :: Off Word16) + i) - {-# INLINE copyByteOffToMBytesMem #-} - copyByteOffToPtrMem (T.Text a o _) i = - copyByteOffToPtrMem a (toByteOff (Off o :: Off Word16) + i) - {-# INLINE copyByteOffToPtrMem #-} - compareByteOffToPtrMem (T.Text a o _) off = - compareByteOffToPtrMem a (toByteOff (Off o :: Off Word16) + off) - {-# INLINE compareByteOffToPtrMem #-} - compareByteOffToBytesMem (T.Text a o _) off = - compareByteOffToBytesMem a (toByteOff (Off o :: Off Word16) + off) - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem off1 (T.Text a o _) off2 = - compareByteOffMem mem off1 a (toByteOff (Off o :: Off Word16) + off2) - {-# INLINE compareByteOffMem #-} - - -instance MemRead ShortByteString where - byteCountMem = byteCountMem . fromShortByteStringBytes - {-# INLINE byteCountMem #-} - indexOffMem sbs = indexOffMem (fromShortByteStringBytes sbs) - {-# INLINE indexOffMem #-} - indexByteOffMem sbs = indexByteOffMem (fromShortByteStringBytes sbs) - {-# INLINE indexByteOffMem #-} - copyByteOffToMBytesMem sbs = copyByteOffToMBytesMem (fromShortByteStringBytes sbs) - {-# INLINE copyByteOffToMBytesMem #-} - copyByteOffToPtrMem sbs = copyByteOffToPtrMem (fromShortByteStringBytes sbs) - {-# INLINE copyByteOffToPtrMem #-} - compareByteOffToPtrMem sbs = compareByteOffToPtrMem (fromShortByteStringBytes sbs) - {-# INLINE compareByteOffToPtrMem #-} - compareByteOffToBytesMem sbs = compareByteOffToBytesMem (fromShortByteStringBytes sbs) - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem off1 sbs = compareByteOffMem mem off1 (fromShortByteStringBytes sbs) - {-# INLINE compareByteOffMem #-} - --- | A wrapper that adds a phantom state token. It can be used with types that either --- doesn't have such state token or are designed to work in `IO` and therefore restricted --- to `RW`. Using this wrapper is very much unsafe, so make sure you know what you are --- doing. -newtype MemState a s = MemState { unMemState :: a } - -instance MemWrite (MemState (ForeignPtr a)) where - readOffMem (MemState fptr) i = withForeignPtr fptr $ \ptr -> readOffPtr (castPtr ptr) i - {-# INLINE readOffMem #-} - readByteOffMem (MemState fptr) i = - withForeignPtr fptr $ \ptr -> readByteOffPtr (castPtr ptr) i - {-# INLINE readByteOffMem #-} - writeOffMem (MemState fptr) i a = withForeignPtr fptr $ \ptr -> writeOffPtr (castPtr ptr) i a - {-# INLINE writeOffMem #-} - writeByteOffMem (MemState fptr) i a = - withForeignPtr fptr $ \ptr -> writeByteOffPtr (castPtr ptr) i a - {-# INLINE writeByteOffMem #-} - moveByteOffToPtrMem (MemState fsrc) srcOff dstPtr dstOff c = - withForeignPtr fsrc $ \srcPtr -> moveByteOffPtrToPtr (castPtr srcPtr) srcOff dstPtr dstOff c - {-# INLINE moveByteOffToPtrMem #-} - moveByteOffToMBytesMem (MemState fsrc) srcOff dst dstOff c = - withForeignPtr fsrc $ \srcPtr -> moveByteOffPtrToMBytes (castPtr srcPtr) srcOff dst dstOff c - {-# INLINE moveByteOffToMBytesMem #-} - copyByteOffMem src srcOff (MemState fdst) dstOff c = - withForeignPtr fdst $ \dstPtr -> - copyByteOffToPtrMem src srcOff (castPtr dstPtr) dstOff c - {-# INLINE copyByteOffMem #-} - moveByteOffMem src srcOff (MemState fdst) dstOff c = - withForeignPtr fdst $ \dstPtr -> - moveByteOffToPtrMem src srcOff (castPtr dstPtr) dstOff c - {-# INLINE moveByteOffMem #-} - setMem (MemState fptr) off c a = withForeignPtr fptr $ \ptr -> setOffPtr (castPtr ptr) off c a - {-# INLINE setMem #-} - -modifyFetchOldMem :: - (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> e) -> m e -modifyFetchOldMem mem o f = modifyFetchOldMemM mem o (pure . f) -{-# INLINE modifyFetchOldMem #-} - - -modifyFetchNewMem :: - (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> e) -> m e -modifyFetchNewMem mem o f = modifyFetchNewMemM mem o (pure . f) -{-# INLINE modifyFetchNewMem #-} - - -modifyFetchOldMemM :: - (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> m e) -> m e -modifyFetchOldMemM mem o f = do - a <- readOffMem mem o - a <$ (writeOffMem mem o =<< f a) -{-# INLINE modifyFetchOldMemM #-} - - -modifyFetchNewMemM :: - (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> m e) -> m e -modifyFetchNewMemM mem o f = do - a <- readOffMem mem o - a' <- f a - a' <$ writeOffMem mem o a' -{-# INLINE modifyFetchNewMemM #-} - - -defaultResizeMem :: - (Prim e, MemAlloc ma, MonadPrim s m) => ma s -> Count e -> m (ma s) -defaultResizeMem mem c = do - let newByteCount = toByteCount c - oldByteCount <- getByteCountMem mem - if oldByteCount == newByteCount - then pure mem - else do - newMem <- allocMem newByteCount - oldMem <- freezeMem mem - newMem <$ copyMem oldMem 0 newMem 0 oldByteCount -{-# INLINE defaultResizeMem #-} - - --- | Place @n@ copies of supplied region of memory one after another in a newly allocated --- contiguous chunk of memory. Similar to `stimes`, but the source memory @memRead@ does --- not have to match the type of `FrozenMem` ma. --- --- ====__Example__ --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> let b = fromListMem @Word8 @(MBytes 'Inc) [0xde, 0xad, 0xbe, 0xef] --- >>> cycleMemN @(MBytes 'Inc) 2 b --- [0xde,0xad,0xbe,0xef,0xde,0xad,0xbe,0xef] --- --- @since 0.1.0 -cycleMemN :: - forall ma mr. (MemAlloc ma, MemRead mr) - => Int - -> mr - -> FrozenMem ma -cycleMemN n r - | n <= 0 = emptyMem - | otherwise = - runST $ do - let bc@(Count chunk) = byteCountMem r - c@(Count c8) = Count n * bc - mem <- allocMem c - let go i = when (i < c8) $ copyByteOffMem r 0 mem (Off i) bc >> go (i + chunk) - go 0 - freezeMem mem -{-# INLINE cycleMemN #-} - - --- | Construct an immutable memory region that can't hold any data. Same as @`mempty` :: --- `FrozenMem` ma@ --- --- ====__Example__ --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> toListMem (emptyMem @(MBytes 'Inc)) :: [Int] --- [] --- --- @since 0.1.0 -emptyMem :: - forall ma. MemAlloc ma - => FrozenMem ma -emptyMem = createMemST_ (0 :: Count Word8) (\_ -> pure ()) -{-# INLINE emptyMem #-} - --- | Allocate a region of immutable memory that holds a single element. --- --- ====__Example__ --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> toListMem (singletonMem @Word16 @(MBytes 'Inc) 0xffff) :: [Word8] --- [255,255] --- --- @since 0.1.0 -singletonMem :: - forall e ma. (MemAlloc ma, Prim e) - => e -- ^ The single element that will be stored in the newly allocated region of memory - -> FrozenMem ma -singletonMem a = createMemST_ (1 :: Count e) $ \mem -> writeOffMem mem 0 a -{-# INLINE singletonMem #-} - --- | Same as `allocMem`, but also use `setMem` to reset all of newly allocated memory to --- zeros. --- --- [Unsafe] When precondition for @memCount@ argument is violated the outcome is --- upredictable. One possible outcome is termination with `Control.Exception.HeapOverflow` --- async exception. --- --- ====__Example__ --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> mb <- allocZeroMem @Int @(MBytes 'Inc) 10 --- >>> b <- freezeMem mb --- >>> toListMem b :: [Int] --- [0,0,0,0,0,0,0,0,0,0] --- --- @since 0.1.0 -allocZeroMem :: - forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) - => Count e - -- ^ /memCount/ - Number of elements to allocate. - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Converted to bytes should be less then available physical memory - -> m (ma s) -allocZeroMem n = do - m <- allocMem n - m <$ setMem m 0 (toByteCount n) (0 :: Word8) -{-# INLINE allocZeroMem #-} - - -createMemST :: - forall e b ma. (MemAlloc ma, Prim e) - => Count e - -> (forall s. ma s -> ST s b) - -> (b, FrozenMem ma) -createMemST n f = runST $ allocMem n >>= \m -> (,) <$> f m <*> freezeMem m -{-# INLINE createMemST #-} - -createMemST_ :: (MemAlloc ma, Prim e) - => Count e - -> (forall s . ma s -> ST s b) - -- ^ /fillAction/ -- Action that will be used to modify contents of newly allocated - -- memory. - -- - -- /__Required invariant:__/ - -- - -- It is important that this action overwrites all of newly allocated memory. - -> FrozenMem ma -createMemST_ n f = runST (allocMem n >>= \m -> f m >> freezeMem m) -{-# INLINE createMemST_ #-} - -createZeroMemST :: - forall e ma b. (MemAlloc ma, Prim e) - => Count e - -> (forall s. ma s -> ST s b) - -> (b, FrozenMem ma) -createZeroMemST n f = runST $ allocZeroMem n >>= \m -> (,) <$> f m <*> freezeMem m -{-# INLINE createZeroMemST #-} - --- | Same as `createMemST_`, except it ensures that the memory gets reset with zeros prior --- to applying the @ST@ filling action @fillAction@. --- --- [Unsafe] Same reasons as `allocZeroMem`: violation of precondition for @memCount@ may --- result in undefined behavior or `Control.Exception.HeapOverflow` async exception. --- --- ====__Example__ --- --- Note that this example will work correctly only on little-endian machines: --- --- >>> :set -XTypeApplications --- >>> import Data.Prim --- >>> import Control.Monad --- >>> let ibs = zip [0, 4 ..] [0x48,0x61,0x73,0x6b,0x65,0x6c,0x6c] :: [(Off Word8, Word8)] --- >>> let c = Count (length ibs) :: Count Char --- >>> let bc = createZeroMemST_ @_ @(MBytes 'Inc) c $ \m -> forM_ ibs $ \(i, b) -> writeByteOffMem m i b --- >>> toListMem bc :: String --- "Haskell" --- --- @since 0.1.0 -createZeroMemST_ :: - forall e ma b. (MemAlloc ma, Prim e) - => Count e - -- ^ /memCount/ - Size of the newly allocated memory region in number of elements of - -- type @e@ - -- - -- /__Precoditions:__/ - -- - -- Size should be non-negative, but smaller than amount of available memory. Note that the - -- second condition simply describes overflow. - -- - -- > 0 <= memCount - -- - -- Possibility of overflow: - -- - -- > unCount memCount <= fromByteCount @e (Count maxBound) - -> (forall s. ma s -> ST s b) - -- ^ /fillAction/ -- Action that will be used to modify contents of newly allocated - -- memory. It is not required to overwrite the full region, since it was reset to zeros - -- right after allocation. - -> FrozenMem ma -createZeroMemST_ n f = runST (allocZeroMem n >>= \m -> f m >> freezeMem m) -{-# INLINE createZeroMemST_ #-} - --- | Copy all of the data from the source into a newly allocate memory region of identical --- size. --- --- ====__Examples__ --- --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> let xs = fromByteListMem @(MBytes 'Pin) [0..15] :: Bytes 'Pin --- >>> let ys = cloneMem xs --- >>> let report bEq pEq = print $ "Bytes equal: " ++ show bEq ++ ", their pointers equal: " ++ show pEq --- >>> withPtrBytes xs $ \ xsPtr -> withPtrBytes ys $ \ ysPtr -> report (xs == ys) (xsPtr == ysPtr) --- "Bytes equal: True, their pointers equal: False" --- --- @since 0.2.0 -cloneMem :: - forall ma. MemAlloc ma - => FrozenMem ma -- ^ /memSource/ - immutable source memory. - -> FrozenMem ma -cloneMem fm = - runST $ do - let n = byteCountMem fm - mm <- allocMem n - copyMem fm 0 mm 0 n - freezeMem mm -{-# INLINE cloneMem #-} - --- | Similar to `copyByteOffMem`, but supply offsets in number of elements instead of --- bytes. Copy contiguous chunk of memory from the read only memory region into the target --- mutable memory region. Source and target /must not/ refer to the same memory region, --- otherwise that would imply that the source is not immutable which would be a violation --- of some other invariant elsewhere in the code. --- --- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ --- or the element count @memCount@ is violated a call to this function can result in: --- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with --- a segfault. --- --- @since 0.1.0 -copyMem :: - (MonadPrim s m, MemRead mr, MemWrite mw, Prim e) - => mr -- ^ /memSourceRead/ - Read-only source memory region from where to copy - -> Off e - -- ^ /memSourceOff/ - Offset into source memory in number of elements of type @e@ - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memSourceOff - -- - -- > unOff memSourceOff < unCount (countMem memSourceRead) - -> mw s -- ^ /memTargetWrite/ - Target mutable memory - -> Off e - -- ^ /memTargetOff/ - Offset into target memory in number of elements - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- With offset applied it should still refer to the same memory region. For types that - -- also implement `MemAlloc` this can be described as: - -- - -- > targetCount <- getCountMem memTargetWrite - -- > unOff memTargetOff < unCount targetCount - -> Count e - -- ^ /memCount/ - Number of elements of type @e@ to copy - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Both source and target memory regions must have enough memory to perform a copy - -- of @memCount@ elements starting at their respective offsets. For @memSourceRead@: - -- - -- > unOff memSourceOff + unCount memCount < unCount (countMem memSourceRead) - -- - -- and for @memTargetWrite@ that also implements `MemAlloc` this can be described as: - -- - -- > targetCount <- getCountMem memTargetWrite - -- > unOff memTargetOff + unCount memCount < unCount targetCount - -> m () -copyMem src srcOff dst dstOff = copyByteOffMem src (toByteOff srcOff) dst (toByteOff dstOff) -{-# INLINE copyMem #-} - - -moveMem :: - (MonadPrim s m, MemWrite mw1, MemWrite mw2, Prim e) - => mw1 s -- ^ Source memory region - -> Off e -- ^ Offset into the source in number of elements - -> mw2 s -- ^ Destination memory region - -> Off e -- ^ Offset into destination in number of elements - -> Count e -- ^ Number of elements to copy over - -> m () -moveMem src srcOff dst dstOff = moveByteOffMem src (toByteOff srcOff) dst (toByteOff dstOff) -{-# INLINE moveMem #-} - - -appendMem :: - forall mr1 mr2 ma. (MemRead mr1, MemRead mr2, MemAlloc ma) - => mr1 - -> mr2 - -> FrozenMem ma -appendMem r1 r2 = - createMemST_ (n1 + n2) $ \mem -> do - copyMem r1 0 mem 0 n1 - copyMem r2 (coerce n1) mem (coerce n1) n2 - where - n1 = byteCountMem r1 - n2 = byteCountMem r2 -{-# INLINABLE appendMem #-} - -concatMem :: - forall mr ma. (MemRead mr, MemAlloc ma) - => [mr] - -> FrozenMem ma -concatMem xs = do - let c = Foldable.foldl' (\ !acc b -> acc + byteCountMem b) 0 xs - createMemST_ c $ \mb -> do - let load i b = do - let cb@(Count n) = byteCountMem b :: Count Word8 - (i + Off n) <$ copyMem b 0 mb i cb - foldM_ load 0 xs -{-# INLINABLE concatMem #-} - - -thawCopyMem :: - forall e mr ma m s. (Prim e, MemRead mr, MemAlloc ma, MonadPrim s m) - => mr - -> Off e - -> Count e - -> m (ma s) -thawCopyMem a off c = do - mem <- allocMem c - mem <$ copyMem a off mem 0 c -{-# INLINE thawCopyMem #-} - -freezeCopyMem :: - forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) - => ma s - -> Off e - -> Count e - -> m (FrozenMem ma) -freezeCopyMem mem off c = freezeMem mem >>= \r -> thawCopyMem r off c >>= freezeMem -{-# INLINE freezeCopyMem #-} - - -thawCloneMem :: - forall mr ma m s. (MemRead mr, MemAlloc ma, MonadPrim s m) - => mr - -> m (ma s) -thawCloneMem a = thawCopyMem a 0 (byteCountMem a) -{-# INLINE thawCloneMem #-} - -freezeCloneMem :: - forall ma m s. (MemAlloc ma, MonadPrim s m) - => ma s - -> m (FrozenMem ma) -freezeCloneMem = freezeMem >=> thawCloneMem >=> freezeMem -{-# INLINE freezeCloneMem #-} - --- | /O(n)/ - Convert a read-only memory region into a newly allocated other type of --- memory region --- --- >>> import Data.ByteString (pack) --- >>> bs = pack [0x10 .. 0x20] --- >>> bs --- "\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US " --- >>> convertMem bs :: Bytes 'Inc --- [0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20] --- --- @since 0.1.0 -convertMem :: (MemRead mr, MemAlloc ma) => mr -> FrozenMem ma -convertMem a = runST $ thawCloneMem a >>= freezeMem -{-# INLINE convertMem #-} - --- | Figure out how many elements fits into the immutable region of memory. It is --- possible that there is a remainder of bytes left, see `countRemMem` for getting that --- too. --- --- ====__Examples__ --- --- >>> b = fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin --- >>> b --- [0x00,0x01,0x02,0x03,0x04,0x05] --- >>> countMem b :: Count Word16 --- Count {unCount = 3} --- >>> countMem b :: Count Word32 --- Count {unCount = 1} --- --- @since 0.1.0 -countMem :: - forall e mr. (MemRead mr, Prim e) - => mr - -> Count e -countMem = fromByteCount . byteCountMem -{-# INLINE countMem #-} - --- | Compute how many elements and a byte size remainder that can fit into the region of memory. --- --- ====__Examples__ --- --- >>> b = fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin --- >>> b --- [0x00,0x01,0x02,0x03,0x04,0x05] --- >>> countRemMem @Word16 b --- (Count {unCount = 3},Count {unCount = 0}) --- >>> countRemMem @Word32 b --- (Count {unCount = 1},Count {unCount = 2}) --- --- @since 0.1.0 -countRemMem :: forall e mr. (MemRead mr, Prim e) => mr -> (Count e, Count Word8) -countRemMem = fromByteCountRem . byteCountMem -{-# INLINE countRemMem #-} - -getCountMem :: forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) => ma s -> m (Count e) -getCountMem = fmap (fromByteCount . coerce) . getByteCountMem -{-# INLINE getCountMem #-} - - -getCountRemMem :: - forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) - => ma s - -> m (Count e, Count Word8) -getCountRemMem = fmap (fromByteCountRem . coerce) . getByteCountMem -{-# INLINE getCountRemMem #-} - - -clone :: - forall ma m s. (MemAlloc ma, MonadPrim s m) - => ma s - -> m (ma s) -clone mb = do - n <- getByteCountMem mb - mb' <- allocMem n - mb' <$ moveMem mb 0 mb' 0 n -{-# INLINE clone #-} - --- | Compare two memory regions byte-by-byte. `False` is returned immediately when sizes --- reported by `byteCountMem` do not match. Computation may be short-circuited on the --- first mismatch, but it is `MemRead` implementation specific. --- --- @since 0.1.0 -eqMem :: (MemRead mr1, MemRead mr2) => mr1 -> mr2 -> Bool -eqMem b1 b2 = n == byteCountMem b2 && compareByteOffMem b1 0 b2 0 n == EQ - where - n = byteCountMem b1 -{-# INLINE eqMem #-} - --- | Compare two regions of memory byte-by-byte. It will return `EQ` whenever both regions --- are exactly the same and `LT` or `GT` as soon as the first byte is reached that is less --- than or greater than respectfully in the first region when compared to the second --- one. It is safe for both regions to refer to the same part of memory, since this is a --- pure function and both regions of memory are read-only. -compareMem :: - forall e mr1 mr2. (MemRead mr1, MemRead mr2, Prim e) - => mr1 -- ^ First region of memory - -> Off e -- ^ Offset in number of elements into the first region - -> mr2 -- ^ Second region of memory - -> Off e -- ^ Offset in number of elements into the second region - -> Count e -- ^ Number of elements to compare - -> Ordering -compareMem r1 off1 r2 off2 = compareByteOffMem r1 (toByteOff off1) r2 (toByteOff off2) -{-# INLINE compareMem #-} - --- =============== -- --- List conversion -- --- =============== -- - -------------- --- To List -- -------------- - --- | Convert an immutable memory region to a list. Whenever memory byte count is not --- exactly divisible by the size of the element there will be some slack left unaccounted --- for. In order to get a hold of this slack use `toListSlackMem` instead. --- --- ====__Examples__ --- --- >>> import Data.Prim.Memory --- >>> import Numeric (showHex) --- >>> let b = fromByteListMem [0x48,0x61,0x73,0x6b,0x65,0x6c,0x6c] :: Bytes 'Inc --- >>> toListMem b :: [Int8] --- [72,97,115,107,101,108,108] --- >>> let xs = toListMem b :: [Word32] --- >>> xs --- [1802723656] --- >>> showHex (head xs) "" --- "6b736148" --- --- @since 0.1.0 -toListMem :: forall e mr. (MemRead mr, Prim e) => mr -> [e] -toListMem ba = build (\ c n -> foldrCountMem (countMem ba) c n ba) -{-# INLINE toListMem #-} -{-# SPECIALIZE toListMem :: Prim e => Bytes p -> [e] #-} - --- | Same as `toListMem`, except when there is some slack towards the end of the memory --- region that didn't fit into a list it will be returned as a list of bytes. --- --- ====__Examples__ --- --- >>> import Data.Word --- >>> :set -XDataKinds --- >>> a = fromListMem [0 .. 10 :: Word8] :: Bytes 'Pin --- >>> a --- [0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] --- >>> toListSlackMem a :: ([Word8], [Word8]) --- ([0,1,2,3,4,5,6,7,8,9,10],[]) --- >>> toListSlackMem a :: ([Word16], [Word8]) --- ([256,770,1284,1798,2312],[10]) --- >>> toListSlackMem a :: ([Word32], [Word8]) --- ([50462976,117835012],[8,9,10]) --- >>> toListSlackMem a :: ([Word64], [Word8]) --- ([506097522914230528],[8,9,10]) --- --- @since 0.1.0 -toListSlackMem :: - forall e mr. (MemRead mr, Prim e) - => mr - -> ([e], [Word8]) -toListSlackMem mem = - (build (\c n -> foldrCountMem k c n mem), getSlack (k8 + r8) []) - where - (k, Count r8) = countRemMem mem - Count k8 = toByteCount k - getSlack i !acc - | i == k8 = acc - | otherwise = - let i' = i - 1 - in getSlack i' (indexByteOffMem mem (Off i') : acc) -{-# INLINABLE toListSlackMem #-} - --- | Right fold that is useful for converting to a list while tapping into list fusion. --- --- [Unsafe] Supplying Count larger than memory holds will result in reading out of bounds --- and a potential segfault. --- --- @since 0.1.0 -foldrCountMem :: forall e b mr. (MemRead mr, Prim e) => Count e -> (e -> b -> b) -> b -> mr -> b -foldrCountMem (Count k) c nil bs = go 0 - where - go i - | i == k = nil - | otherwise = - let !v = indexOffMem bs (Off i) - in v `c` go (i + 1) -{-# INLINE[0] foldrCountMem #-} - ---------------- --- From List -- ---------------- - --- Pure immutable conversion -- - --- | Just like `fromListMemN`, except it ensures safety by using the length of the --- list for allocation. Because it has to figure out the length of the list first it --- will be just a little bit slower, but that much safer. --- --- ====__Examples__ --- --- >>> import Data.Prim.Memory --- >>> :set -XDataKinds --- >>> fromListMem "Hi" :: Bytes 'Inc --- [0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00] --- --- @since 0.1.0 -fromListMem :: - forall e ma. (Prim e, MemAlloc ma) - => [e] - -> FrozenMem ma -fromListMem xs = - let count = coerce (length xs) `countForProxyTypeOf` xs - in createMemST_ count (loadListMemN_ count xs) -{-# INLINE fromListMem #-} - - --- | Same as `fromListMem` but restricted to a list of `Word8`. Load a list of bytes into --- a newly allocated memory region. Equivalent to `Data.ByteString.pack` for --- `Data.ByteString.ByteString` --- --- ====__Examples__ --- --- >>> fromByteListMem [0..10] :: Bytes 'Pin --- [0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] --- --- @since 0.1.0 -fromByteListMem :: - forall ma. MemAlloc ma - => [Word8] - -> FrozenMem ma -fromByteListMem = fromListMem -{-# INLINE fromByteListMem #-} - - --- | Similarly to `fromListMem` load a list into a newly allocated memory region, but --- unlike the aforementioned function it also accepts a hint of how many elements is --- expected to be in the list. Because the number of expected an actual elements might --- not match we return not only the frozen memory region, but also: --- --- * either a list with leftover elements from the input @list@, if it did not fully fit --- into the allocated region. An empty list would indicate that it did fit exactly. --- --- @ --- unCount memCount <= length list --- @ --- --- * or an exact count of how many elements have been loaded when there was no --- enough elements in the list --- --- --- In the latter case a zero value would indicate that the list did fit into the newly --- allocated memory region exactly, which is perfectly fine. But a positive value would --- mean that the tail of the memory region is still unset and might contain garbage --- data. Make sure to overwrite the surplus memory yourself or use the safe version --- `fromListZeroMemN` that fills the surplus with zeros. --- --- [Unsafe] Whenever @memCount@ precodition is violated, because on each call with the --- same input it can produce different output therefore it will break referential --- transparency. --- --- ====__Examples__ --- --- >>> :set -XTypeApplications --- >>> fromListMemN @Char @(MBytes 'Inc) 3 "Hello" --- (Left "lo",[0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00]) --- >>> fromListMemN @Char @(MBytes 'Inc) 2 "Hi" --- (Left "",[0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00]) --- >>> fst $ fromListMemN @Char @(MBytes 'Inc) 5 "Hi" --- Right (Count {unCount = 2}) --- --- @since 0.2.0 -fromListMemN :: - forall e ma. (Prim e, MemAlloc ma) - => Count e - -- ^ /memCount/ - Expected number of elements in the list, which exactly how much - -- memory will be allocated. - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- > unCount memCount <= length list - -> [e] - -- ^ /list/ - A list of elements to load into the newly allocated memory region. - -> (Either [e] (Count e), FrozenMem ma) -fromListMemN count xs = - createMemST count $ \mm -> do - (ys, loadedCount) <- loadListOffMemN count xs mm 0 - pure $ - if loadedCount /= count && null ys - then Right loadedCount - else Left ys -{-# INLINE fromListMemN #-} - - --- | Just like `fromListMemN`, except it ensures safety by filling tail with zeros, --- whenever the list is not long enough. --- --- ====__Examples__ --- --- >>> import Data.Prim.Memory --- >>> :set -XTypeApplications --- >>> fromListZeroMemN @Char @(MBytes 'Inc) 3 "Hi" --- (Right (Count {unCount = 2}),[0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00,0x00,0x00,0x00,0x00]) --- --- @since 0.2.0 -fromListZeroMemN :: - forall e ma. (Prim e, MemAlloc ma) - => Count e -- ^ /memCount/ - Number of elements to load from the list. - -> [e] - -> (Either [e] (Count e), FrozenMem ma) -fromListZeroMemN count xs = - createMemST (max 0 count) $ \mm -> do - (ys, loadedCount) <- loadListOffMemN count xs mm 0 - let loadedByteCount = toByteCount loadedCount - surplusByteCount = toByteCount count - loadedByteCount - when (surplusByteCount > 0) $ setMem mm (countToOff loadedByteCount) surplusByteCount 0 - pure $ - if loadedCount /= count && null ys - then Right loadedCount - else Left ys -{-# INLINE fromListZeroMemN #-} - --- | Same as `fromListZeroMemN`, but ignore the extra information about how the loading went. --- --- ====__Examples__ --- --- >>> import Data.Prim.Memory --- >>> fromListZeroMemN_ 3 "Hi" :: Bytes 'Inc --- [0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00,0x00,0x00,0x00,0x00] --- --- @since 0.2.0 -fromListZeroMemN_ :: - forall e ma. (Prim e, MemAlloc ma) - => Count e - -> [e] - -> FrozenMem ma -fromListZeroMemN_ !n = snd . fromListZeroMemN n -{-# INLINE fromListZeroMemN_ #-} - - - --- Mutable loading -- - - -loadListByteOffHelper :: - (MemWrite mw, MonadPrim s m, Prim e) - => [e] - -> mw s - -> Off Word8 -- ^ Offset - -> Off Word8 -- ^ Upper bound - -> Off Word8 -- ^ Element size - -> m ([e], Count e) -loadListByteOffHelper ys mw byteOff k step = - let go [] i = pure ([], toLoadedCount i) - go a@(x:xs) i - | i < k = writeByteOffMem mw i x >> go xs (i + step) - | otherwise = pure (a, toLoadedCount i) - toLoadedCount i = fromByteCount (offToCount (i - byteOff)) - in go ys byteOff -{-# INLINE loadListByteOffHelper #-} - - --- | Load elements from the supplied list into a mutable memory region. Loading will --- start at the supplied offset in number of bytes and will stop when either supplied --- @elemCount@ number is reached or there are no more elements left in the list to --- load. This action returns a list of elements that did not get loaded and the count of --- how many elements did get loaded. --- --- [Unsafe] When any precondition for either the offset @memTargetOff@ or the element --- count @memCount@ is violated then a call to this function can result in heap corruption --- or failure with a segfault. --- --- ====__Examples__ --- --- For example load the @"Hell"@ somewhere in the middle of `MBytes`: --- --- >>> ma <- allocZeroMem (6 :: Count Char) :: IO (MBytes 'Inc RW) --- >>> loadListByteOffMemN 4 "Hello!" ma (toByteOff (1 :: Off Char)) --- ("o!",Count {unCount = 4}) --- >>> freezeMem ma --- [0x00,0x00,0x00,0x00,0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x00,0x00,0x00,0x00] --- --- Or something more usful like loading prefixes from nested lists: --- --- >>> import Control.Monad --- >>> foldM_ (\o xs -> (+ o) . countToByteOff . snd <$> loadListByteOffMemN 4 xs ma o) 2 [[x..] | x <- [1..5] :: [Word8]] --- >>> freezeMem ma --- [0x00,0x00,0x01,0x02,0x03,0x04,0x02,0x03,0x04,0x05,0x03,0x04,0x05,0x06,0x04,0x05,0x06,0x07,0x05,0x06,0x07,0x08,0x00,0x00] --- --- @since 0.2.0 -loadListByteOffMemN :: - (MemWrite mw, MonadPrim s m, Prim e) - => Count e - -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Target memory region must have enough memory to perform loading of @elemCount@ - -- elements starting at the @memTargetOff@ offset. For types that also implement - -- `MemAlloc` this can be described as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOff memTargetOff + unCountBytes elemCount <= unCount (targetByteCount - byteCountType @e) - -> [e] -- ^ /listSource/ - List with elements that should be loaded - -> mw s -- ^ /memTarget/ - Memory region where to load the elements into - -> Off Word8 - -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory - -- region @memTarget@. For types that also implement `MemAlloc` this can be described - -- as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListByteOffMemN count ys mw byteOff = loadListByteOffHelper ys mw byteOff k step - where - k = byteOff + countToOff (toByteCount count) - step = countToOff $ byteCountProxy ys -{-# INLINABLE loadListByteOffMemN #-} - --- | Same as `loadListByteOffMemN`, but infer the count from number of bytes that is --- available in the target memory region. --- --- [Unsafe] When a precondition for the element count @memCount@ is violated then a call --- to this function can result in heap corruption or failure with a segfault. --- --- ====__Examples__ --- --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> ma <- allocZeroMem (5 :: Count Char) :: IO (MBytes 'Inc RW) --- >>> freezeMem ma --- [0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00] --- >>> loadListByteOffMem "Hello World" ma 0 --- (" World",Count {unCount = 5}) --- >>> freezeMem ma --- [0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] --- >>> loadListByteOffMem ([0xff,0xff,0xff] :: [Word8]) ma 1 --- ([],Count {unCount = 3}) --- >>> freezeMem ma --- [0x48,0xff,0xff,0xff,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] --- --- @since 0.2.0 -loadListByteOffMem :: - (MemAlloc ma, MonadPrim s m, Prim e) - => [e] -- ^ /listSource/ - List with elements that should be loaded - -> ma s -- ^ /memTarget/ - Memory region where to load the elements into - -> Off Word8 - -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory - -- region @memTarget@. For types that also implement `MemAlloc` this can be described - -- as: - -- - -- > targetByteCount <- getByteCountMem memTarget - -- > unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListByteOffMem ys ma byteOff = do - bCount <- getByteCountMem ma - let k = countToOff bCount - byteOff - step = countToOff $ byteCountProxy ys - loadListByteOffHelper ys ma byteOff k step -{-# INLINABLE loadListByteOffMem #-} - --- | Same as `loadListByteOffMemN`, but works with offset in number of elements instead of --- bytes. --- --- [Unsafe] When preconditions for either the offset @memTargetOff@ or the element count --- @memCount@ is violated then a call to this function can result in heap corruption or --- failure with a segfault. --- --- @since 0.2.0 -loadListOffMemN :: - (MemWrite mw, MonadPrim s m, Prim e) - => Count e - -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Target memory region must have enough memory to perform loading of @elemCount@ - -- elements starting at the @memTargetOff@ offset. For types that also implement - -- `MemAlloc` this can be described as: - -- - -- > targetCount <- getCountMem memTarget - -- > unOff memTargetOff + unCount elemCount < unCount targetCount - -> [e] -- ^ /listSource/ - List with elements that should be loaded - -> mw s -- ^ /memTarget/ - Memory region where to load the elements into - -> Off e - -- ^ /memTargetOff/ - Offset in number of elements into target memory where writing will start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory - -- region @memTarget@. For types that also implement `MemAlloc` this can be described - -- as: - -- - -- > targetCount <- getByteCountMem memTarget - -- > unOff memTargetOff < unCount targetCount - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListOffMemN count ys mw off = - let go [] i = pure ([], toLoadedCount i) - go a@(x:xs) i - | i < k = writeOffMem mw i x >> go xs (i + 1) - | otherwise = pure (a, toLoadedCount i) - k = off + countToOff count - toLoadedCount i = offToCount (i - off) - in go ys off -{-# INLINABLE loadListOffMemN #-} - - --- | Same as `loadListOffMemN`, but start loading at @0@ offset. --- --- [Unsafe] When any precondition for the element count @memCount@ is violated then a call to --- this function can result in heap corruption or failure with a segfault. --- --- @since 0.2.0 -loadListMemN :: - forall e mw m s. (MemWrite mw, MonadPrim s m, Prim e) - => Count e - -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Target memory region must have enough memory to perform loading of @elemCount@ - -- elements. For types that also implement `MemAlloc` this can be described as: - -- - -- > targetCount <- getCountMem memTarget - -- > elemCount <= targetCount - -> [e] -- ^ /listSource/ - List with elements that should be loaded - -> mw s -- ^ /memTarget/ - Memory region where to load the elements into - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListMemN count xs mw = loadListOffMemN count xs mw 0 -{-# INLINABLE loadListMemN #-} - - - --- | Same as `loadListMemN`, but ignores the result. --- --- [Unsafe] When any precondition for the element count @memCount@ is violated then a call --- to this function can result in heap corruption or failure with a segfault. --- --- @since 0.2.0 -loadListMemN_ :: - forall e mw m s. (Prim e, MemWrite mw, MonadPrim s m) - => Count e - -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memCount - -- - -- Target memory region must have enough memory to perform loading of @elemCount@ - -- elements. For types that also implement `MemAlloc` this can be described as: - -- - -- > targetCount <- getCountMem memTarget - -- > elemCount <= targetCount - -> [e] -- ^ /listSource/ - List with elements that should be loaded - -> mw s -- ^ /memTarget/ - Memory region where to load the elements into - -> m () -loadListMemN_ (Count n) ys mb = - let go [] _ = pure () - go (x:xs) i = when (i < n) $ writeOffMem mb (Off i) x >> go xs (i + 1) - in go ys 0 -{-# INLINABLE loadListMemN_ #-} - - - - --- | Same as `loadListOffMemN`, but infer the count from number of bytes that is available --- in the target memory region. --- --- [Unsafe] When a precondition for the element count @memCount@ is violated then a call --- to this function can result in heap corruption or failure with a segfault. --- --- @since 0.2.0 -loadListOffMem :: - forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) - => [e] -- ^ /listSource/ - List with elements that should be loaded - -> ma s -- ^ /memTarget/ - Memory region where to load the elements into - -> Off e - -- ^ /memTargetOff/ - Offset in number of elements into target memory where writing will - -- start - -- - -- /__Preconditions:__/ - -- - -- > 0 <= memTargetOff - -- - -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory - -- region @memTarget@. For types that also implement `MemAlloc` this can be described - -- as: - -- - -- > targetCount <- getCountMem memTarget - -- > unOff memTargetOff < unCount targetCount - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListOffMem ys ma off = getCountMem ma >>= \c -> loadListOffMemN (c - offToCount off) ys ma off -{-# INLINE loadListOffMem #-} - - --- | Same as `loadListMemN`, but tries to fit as many elements as possible into the mutable --- memory region starting at the beginning. This operation is always safe. --- --- ====__Examples__ --- --- >>> import Data.Prim.Memory --- >>> ma <- allocMem (5 :: Count Char) :: IO (MBytes 'Inc RW) --- >>> loadListMem "HelloWorld" ma --- ("World",Count {unCount = 5}) --- >>> freezeMem ma --- [0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] --- >>> loadListMem (replicate 6 (0xff :: Word8)) ma --- ([],Count {unCount = 6}) --- >>> freezeMem ma --- [0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] --- --- @since 0.2.0 -loadListMem :: - forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) - => [e] -- ^ /listSource/ - List with elements to load - -> ma s -- ^ /memTarget/ - Mutable region where to load elements from the list - -> m ([e], Count e) - -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. -loadListMem ys ma = getCountMem ma >>= \c -> loadListOffMemN (c `countForProxyTypeOf` ys) ys ma 0 -{-# INLINE loadListMem #-} - --- | Same as `loadListMem`, but ignores the result. Equivalence as property: --- --- prop> let c = fromInteger (abs i) :: Count Int in (createZeroMemST_ c (loadListMem_ (xs :: [Int])) :: Bytes 'Inc) == createZeroMemST_ c (void . loadListMem xs) --- --- @since 0.2.0 -loadListMem_ :: - forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) - => [e] -- ^ /listSource/ - List with elements to load - -> ma s -- ^ /memTarget/ - Mutable region where to load elements from the list - -> m () -loadListMem_ ys mb = getCountMem mb >>= \c -> loadListMemN_ (c `countForProxyTypeOf` ys) ys mb -{-# INLINE loadListMem_ #-} - - --- | Convert a memory region to a list of bytes. Equivalent to `Data.ByteString.unpack` --- for `Data.ByteString.ByteString` --- --- ====__Example__ --- --- >>> toByteListMem (fromByteListMem [0..10] :: Bytes 'Pin) --- [0,1,2,3,4,5,6,7,8,9,10] --- --- @since 0.1.0 -toByteListMem :: - forall ma. MemAlloc ma - => FrozenMem ma - -> [Word8] -toByteListMem = toListMem -{-# INLINE toByteListMem #-} - --- mapMem :: --- forall e e' mr ma. (MemRead mr, MemAlloc ma, Prim e, Prim e') --- => (e -> e') --- -> mr --- -> (FrozenMem ma, [Word8]) --- mapMem f = undefined - - -mapByteMem :: - forall e mr ma. (MemRead mr, MemAlloc ma, Prim e) - => (Word8 -> e) - -> mr - -> FrozenMem ma -mapByteMem f = imapByteOffMem (const f) - --- Map an index aware function over memory region --- --- >>> import Data.Prim.Memory --- >>> a = fromListMem [1 .. 10 :: Word8] :: Bytes 'Inc --- >>> a --- [0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] --- >>> imapByteOffMem (\i e -> (fromIntegral i :: Int8, e + 0xf0)) a :: Bytes 'Pin --- [0x00,0xf1,0x01,0xf2,0x02,0xf3,0x03,0xf4,0x04,0xf5,0x05,0xf6,0x06,0xf7,0x07,0xf8,0x08,0xf9,0x09,0xfa] --- --- @since 0.1.0 -imapByteOffMem :: - (MemRead mr, MemAlloc ma, Prim e) => (Off Word8 -> Word8 -> e) -> mr -> FrozenMem ma -imapByteOffMem f r = runST $ mapByteOffMemM (\i -> pure . f i) r - --- @since 0.1.0 -mapByteMemM :: - (MemRead mr, MemAlloc ma, MonadPrim s m, Prim e) - => (Word8 -> m e) - -> mr - -> m (FrozenMem ma) -mapByteMemM f = mapByteOffMemM (const f) - - --- @since 0.1.0 -mapByteOffMemM :: - forall e mr ma m s. (MemRead mr, MemAlloc ma, MonadPrim s m, Prim e) - => (Off Word8 -> Word8 -> m e) - -> mr - -> m (FrozenMem ma) -mapByteOffMemM f r = do - let bc@(Count n) = byteCountMem r - c = Count n `countForProxyTypeOf` f 0 0 - mem <- allocMem c - _ <- forByteOffMemM_ r 0 bc f - -- let go i = - -- when (i < n) $ do - -- f i (indexByteOffMem r (Off i)) >>= - -- writeOffMem mem (offAsProxy c (Off i)) - -- go (i + 1) - -- go 0 - freezeMem mem - - --- | Iterate over a region of memory -forByteOffMemM_ :: - (MemRead mr, MonadPrim s m, Prim e) - => mr - -> Off Word8 - -> Count e - -> (Off Word8 -> e -> m b) - -> m (Off Word8) -forByteOffMemM_ r (Off byteOff) c f = - let n = coerce (toByteCount c) + byteOff - Count k = byteCountProxy c - go i - | i < n = f (Off i) (indexByteOffMem r (Off i)) >> go (i + k) - | otherwise = pure $ Off i - in go byteOff - -loopShortM :: Monad m => Int -> (Int -> a -> Bool) -> (Int -> Int) -> a -> (Int -> a -> m a) -> m a -loopShortM !startAt condition increment !initAcc f = go startAt initAcc - where - go !step !acc - | condition step acc = f step acc >>= go (increment step) - | otherwise = pure acc -{-# INLINE loopShortM #-} - -loopShortM' :: Monad m => Int -> (Int -> a -> m Bool) -> (Int -> Int) -> a -> (Int -> a -> m a) -> m a -loopShortM' !startAt condition increment !initAcc f = go startAt initAcc - where - go !step !acc = - condition step acc >>= \cont -> - if cont - then f step acc >>= go (increment step) - else pure acc -{-# INLINE loopShortM' #-} - --- -- | Iterate over a region of memory --- loopMemM_ :: --- (MemRead mr, MonadPrim s m, Prim e) --- => r --- -> Off Word8 --- -> Count e --- -> (Count Word8 -> a -> Bool) --- -> (Off Word8 -> e -> m b) --- -> m (Off Word8) --- foldlByteOffMemM_ r (Off byteOff) c f = --- loopShortM byteOff (\i -> f (coerce i)) --- let n = coerce (toByteCount c) + byteOff --- Count k = byteCountProxy c --- go i --- | i < n = f (Off i) (indexByteOffMem r (Off i)) >> go (i + k) --- | otherwise = pure $ Off i --- in go byteOff - - -data MemView a = MemView - { mvOffset :: {-# UNPACK #-} !(Off Word8) - , mvCount :: {-# UNPACK #-} !(Count Word8) - , mvMem :: !a - } - -data MMemView a s = MMemView - { mmvOffset :: {-# UNPACK #-} !(Off Word8) - , mmvCount :: {-# UNPACK #-} !(Count Word8) - , mmvMem :: !(a s) - } - -izipWithByteOffMemM_ :: - (MemRead mr1, MemRead mr2, MonadPrim s m, Prim e) - => mr1 - -> Off Word8 - -> mr2 - -> Off Word8 - -> Count e - -> (Off Word8 -> e -> Off Word8 -> e -> m b) - -> m (Off Word8) -izipWithByteOffMemM_ r1 (Off byteOff1) r2 off2 c f = - let n = coerce (toByteCount c) + byteOff1 - Count k = byteCountProxy c - go i - | i < n = - let o1 = Off i - o2 = Off i + off2 - in f o1 (indexByteOffMem r1 o1) o2 (indexByteOffMem r2 o2) >> - go (i + k) - | otherwise = pure $ Off i - in go byteOff1 - - -izipWithOffMemM_ :: - (MemRead mr1, MemRead mr2, MonadPrim s m, Prim e1, Prim e2) - => mr1 - -> Off e1 - -> mr2 - -> Off e2 - -> Int - -> (Off e1 -> e1 -> Off e2 -> e2 -> m b) - -> m () -izipWithOffMemM_ r1 off1 r2 off2 nc f = - let n = nc + coerce off1 - go o1@(Off i) o2 = - when (i < n) $ - f o1 (indexOffMem r1 o1) o2 (indexOffMem r2 o2) >> go (o1 + 1) (o2 + 1) - in go off1 off2 - - --- class Mut f => MFunctor f where --- mmap :: (Elt f a, Elt f b, MonadPrim s m) => (a -> b) -> f a s -> m (f b s) - --- class Mut f => MTraverse f where --- mmapM :: (Elt f a, Elt f b, MonadPrim s m) => (a -> m b) -> f a s -> m (f b s) - --- class MFunctor f => MApplicative f where --- pureMut :: (Elt f a, MonadPrim s m) => a -> m (f a s) --- liftMut :: --- (Elt f a, Elt f b, Elt f c, MonadPrim s m) => (a -> b -> m c) -> f a s -> f b s -> m (f c s) - --- class MApplicative f => MMonad f where --- bindMut :: --- (Elt f a, Elt f b, MonadPrim s m) => f a s -> (a -> m b) -> f b s -> m (f c s) - --- instance MFunctor MAddr where --- mmap f maddr = do --- Count n <- getCountMAddr maddr --- maddr' <- allocMAddr (Count n) --- let go i = --- when (i < n) $ do --- writeOffMAddr maddr' (Off i) . f =<< readOffMAddr maddr (Off i) --- go (i + 1) --- maddr' <$ go 0 - --- instance MTraverse MAddr where --- mmapM f maddr = do --- Count n <- getCountMAddr maddr --- maddr' <- allocMAddr (Count n) --- let go i = --- when (i < n) $ do --- writeOffMAddr maddr' (Off i) =<< f =<< readOffMAddr maddr (Off i) --- go (i + 1) --- maddr' <$ go 0 - - ---------------------- --- Bytes instances -- ---------------------- - -instance MemRead (Bytes p) where - byteCountMem = byteCountBytes - {-# INLINE byteCountMem #-} - indexOffMem = indexOffBytes - {-# INLINE indexOffMem #-} - indexByteOffMem = indexByteOffBytes - {-# INLINE indexByteOffMem #-} - copyByteOffToMBytesMem = copyByteOffBytesToMBytes - {-# INLINE copyByteOffToMBytesMem #-} - copyByteOffToPtrMem = copyByteOffBytesToPtr - {-# INLINE copyByteOffToPtrMem #-} - compareByteOffToPtrMem bytes1 off1 ptr2 off2 c = - pure $! compareByteOffBytesToPtr bytes1 off1 ptr2 off2 c - {-# INLINE compareByteOffToPtrMem #-} - compareByteOffToBytesMem bytes1 off1 bytes2 off2 c = - compareByteOffBytes bytes1 off1 bytes2 off2 c - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem1 off1 bs off2 c = - compareByteOffToBytesMem mem1 off1 bs off2 c - {-# INLINE compareByteOffMem #-} - -instance Typeable p => MemAlloc (MBytes p) where - type FrozenMem (MBytes p) = Bytes p - getByteCountMem = getByteCountMBytes - {-# INLINE getByteCountMem #-} - allocMem = allocMBytes - {-# INLINE allocMem #-} - thawMem = thawBytes - {-# INLINE thawMem #-} - freezeMem = freezeMBytes - {-# INLINE freezeMem #-} - resizeMem = reallocMBytes - {-# INLINE resizeMem #-} - -instance MemWrite (MBytes p) where - readOffMem = readOffMBytes - {-# INLINE readOffMem #-} - readByteOffMem = readByteOffMBytes - {-# INLINE readByteOffMem #-} - writeOffMem = writeOffMBytes - {-# INLINE writeOffMem #-} - writeByteOffMem = writeByteOffMBytes - {-# INLINE writeByteOffMem #-} - moveByteOffToPtrMem = moveByteOffMBytesToPtr - {-# INLINE moveByteOffToPtrMem #-} - moveByteOffToMBytesMem = moveByteOffMBytesToMBytes - {-# INLINE moveByteOffToMBytesMem #-} - moveByteOffMem = moveByteOffToMBytesMem - {-# INLINE moveByteOffMem #-} - copyByteOffMem = copyByteOffToMBytesMem - {-# INLINE copyByteOffMem #-} - setMem = setMBytes - {-# INLINE setMem #-} - - -instance Show (Bytes p) where - show b = - Foldable.foldr' ($) "]" $ - ('[' :) : List.intersperse (',' :) (map (("0x" ++) .) (showsHexMem b)) - -instance Typeable p => IsList (Bytes p) where - type Item (Bytes p) = Word8 - fromList = fromListMem - {-# INLINE fromList #-} - fromListN n = fromListZeroMemN_ (Count n) - {-# INLINE fromListN #-} - toList = toListMem - {-# INLINE toList #-} - -instance Eq (Bytes p) where - b1 == b2 = isSameBytes b1 b2 || eqMem b1 b2 - {-# INLINE (==) #-} - -instance Ord (Bytes p) where - compare b1 b2 = - compare n (byteCountBytes b2) <> compareByteOffBytes b1 0 b2 0 n - where - n = byteCountBytes b1 - {-# INLINE compare #-} - -instance Typeable p => Semigroup.Semigroup (Bytes p) where - (<>) = appendMem - {-# INLINE (<>) #-} - sconcat (x :| xs) = concatMem (x:xs) - {-# INLINE sconcat #-} - stimes i = cycleMemN (fromIntegral i) - {-# INLINE stimes #-} - -instance Typeable p => Monoid.Monoid (Bytes p) where - mappend = appendMem - {-# INLINE mappend #-} - mconcat = concatMem - {-# INLINE mconcat #-} - mempty = emptyMem - {-# INLINE mempty #-} - - --- | A list of `ShowS` which covert bytes to base16 encoded strings. Each element of the list --- is a function that will convert one byte. --- --- ====__Example__ --- --- >>> :set -XDataKinds --- >>> import Data.Prim.Memory --- >>> concatMap ($ " ") $ showsHexMem (fromListMem [1 :: Int16 .. 15] :: Bytes 'Inc) --- "01 00 02 00 03 00 04 00 05 00 06 00 07 00 08 00 09 00 0a 00 0b 00 0c 00 0d 00 0e 00 0f 00 " --- --- @since 0.1.0 -showsHexMem :: MemRead mr => mr -> [ShowS] -showsHexMem b = map toHex (toListMem b :: [Word8]) - where - toHex b8 = - (if b8 <= 0x0f - then ('0' :) - else id) . - showHex b8 - --- | Ensure that memory is filled with zeros before and after it gets used. `PtrAccess` is --- not used directly, but istead is used to guarantee that the memory is pinned and its --- contents do get moved around by the garbage collector. --- --- @since 0.2.0 -withScrubbedMem :: - forall e ma m a. - (MonadUnliftPrim RW m, Prim e, MemAlloc ma, PtrAccess RW (ma RW)) - => Count e - -> (ma RW -> m a) - -> m a -withScrubbedMem c f = do - mem <- allocZeroMem c - let _fptr = toForeignPtr mem :: IO (ForeignPtr e) -- Force the `PtrAccess` constraint. - f mem `finallyPrim` setMem mem 0 (toByteCount c) 0 - where - finallyPrim m1 m2 = withRunInPrimBase $ \run -> finally (run m1) (run m2) -{-# INLINE withScrubbedMem #-} +import Control.Prim.Exception +import Control.Prim.Monad.Unsafe +import qualified Data.ByteString as BS +import Data.Foldable as Foldable +import Data.Kind +import Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Monoid as Monoid +import Data.Prim +import Data.Prim.Array +import Data.Prim.Memory.Bytes.Internal +import Data.Prim.Memory.ByteString +import Data.Prim.Memory.ForeignPtr +import Data.Prim.Memory.Ptr +import qualified Data.Prim.Memory.Text as T +import qualified Data.Semigroup as Semigroup +import Foreign.Prim +import Numeric (showHex) + +-- | Type class that can be implemented for an immutable data type that provides +-- read-only direct access to memory +class MemRead mr where + + -- | Check if two read only regions refer to the exact same region of memory + -- + -- @since 0.3.0 + isSameMem :: mr -> mr -> Bool + + -- | Number of bytes allocated by the data type available for reading. + -- + -- ====__Example__ + -- + -- >>> :set -XDataKinds + -- >>> import Data.Prim.Memory + -- >>> byteCountMem (fromByteListMem [1,2,3] :: Bytes 'Inc) + -- Count {unCount = 3} + -- + -- @since 0.1.0 + byteCountMem :: mr -> Count Word8 + + -- | Read an element with an offset in number of elements, rather than bytes as is the + -- case with `indexByteOffMem`. + -- + -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the + -- result is either unpredictable output or failure with a segfault. + -- + -- @since 0.1.0 + indexOffMem :: Prim e + => mr -- ^ /memRead/ - Memory to read an element from + -> Off e + -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= off + -- + -- > unOffBytes off <= unCount (byteCountMem memRead - byteCountType @e) + -- + -> e + indexOffMem mr off = indexByteOffMem mr (toByteOff off) + {-# INLINE indexOffMem #-} + + -- | Read an element with an offset in number of bytes. Bounds are not checked. + -- + -- [Unsafe] When precondition for @off@ argument is violated the result is either + -- unpredictable output or failure with a segfault. + -- + -- @since 0.1.0 + indexByteOffMem :: Prim e + => mr -- ^ /memRead/ - Memory to read an element from + -> Off Word8 + -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= unOff off + -- + -- > unOff off <= unCount (byteCountMem memRead - byteCountType @e) + -- + -> e + + -- | Copy contiguous chunk of memory from the read only memory into the target mutable + -- `MBytes`. Source and target /must not/ refer to the same memory region, otherwise + -- that would imply that the source is not immutable which would be a violation of some + -- other invariant elsewhere in the code. + -- + -- [Unsafe] When a precondition for either of the offsets @memSourceOff@, @memTargetOff@ + -- or the element count @memCount@ is violated the result is either unpredictable output or + -- failure with a segfault. + -- + -- @since 0.1.0 + copyByteOffToMBytesMem :: + (MonadPrim s m, Prim e) + => mr -- ^ /memSourceRead/ - Source from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset into source memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) + -> MBytes p s -- ^ /memTargetWrite/ - Target mutable memory + -> Off Word8 + -- ^ /memTargetOff/ - Offset into target memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- > unOff memTargetOff <= unCount (byteCountMem memTargetWrite - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unCountBytes memCount + unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) + -- + -- > unCountBytes memCount + unOff memTargetOff <= unCount (byteCountMem memTargetRead - byteCountType @e) + -> m () + + -- | Copy contiguous chunk of memory from the read only memory into the target mutable + -- `Ptr`. Source and target /must not/ refer to the same memory region, otherwise that + -- would imply that the source is not immutable which would be a violation of some other + -- invariant elsewhere in the code. + -- + -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ + -- or the element count @memCount@ is violated a call to this function can result in: + -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with + -- a segfault. + -- + -- + -- @since 0.1.0 + copyByteOffToPtrMem :: + (MonadPrim s m, Prim e) + => mr -- ^ /memSourceRead/ - Source from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset into source memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) + -> Ptr e + -- ^ /memTargetWrite/ - Pointer to the target mutable memory + -- + -- /__Preconditions:__/ + -- + -- Once the pointer is advanced by @memTargetOff@ the next @unCountBytes memCount@ bytes must + -- still belong to the same region of memory @memTargetWrite@ + -> Off Word8 + -- ^ /memTargetOff/ - Number of bytes to advance the pointer @memTargetWrite@ forward + -- + -- /__Precondition:__/ + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same + -- memory region @memTargetWrite@ + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unCountBytes memCount + unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) + -> m () + + -- | Same as `compareByteOffMem`, but compare the read-only + -- memory region to a region addressed by a `Ptr` inside of a `MonadPrim`. + -- + -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@, the + -- pointer @memRead2@ or the element count @memCount@ is violated the result is either + -- unpredictable output or failure with a segfault. + -- + -- @since 0.1.0 + compareByteOffToPtrMem :: + (MonadPrim s m, Prim e) + => mr -- ^ /memRead1/ - First memory region + -> Off Word8 + -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memOff1 + -- + -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -> Ptr e + -- ^ /memRead2/- Second memory region that can be accessed by a pointer + -- + -- /__Preconditions__/ + -- + -- Once the pointer is advanced by @memOff2@ the next @unCountBytes memCount@ bytes must + -- still belong to the same region of memory @memRead2@ + -> Off Word8 + -- ^ /memOff2/ - Number of bytes to advance the pointer @memRead2@ forward + -- + -- /__Precondition:__/ + -- + -- Once the pointer is advanced by @memOff2@ it must still refer to the same memory + -- region @memRead2@ + -> Count e -- ^ /memCount/ - Number of elements of type __@e@__ to compare as binary + -- ^ /memCount/ - Number of elements of type __@e@__ to compare as binary + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -> m Ordering + + -- | Same as `compareByteOffMem`, but compare the read-only memory region to `Bytes`. + -- + -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the + -- element count @memCount@ is violated the result is either unpredictable output or + -- failure with a segfault. + -- + -- @since 0.1.0 + compareByteOffToBytesMem :: + Prim e + => mr -- ^ /memRead1/ - First memory region + -> Off Word8 + -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memOff1 + -- + -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -> Bytes p -- ^ /memRead2/- Second memory region that is backed by `Bytes` + -> Off Word8 + -- ^ /memOff2/ - Offset for @memRead2@ in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memOff2 + -- + -- > unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to compare as binary + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -- + -- > unCountBytes memCount + unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) + -> Ordering + + -- | Compare two read-only regions of memory byte-by-byte. The very first mismatched + -- byte will cause this function to produce `LT` if the byte in @memRead1@ is smaller + -- than the one in @memRead2@ and `GT` if it is bigger. It is not a requirement to + -- short-circuit on the first mismatch, but it is a good optimization to have for + -- non-sensitive data. Memory regions that store security critical data may choose to + -- implement this function to work in constant time. + -- + -- This function is usually implemented by either one of `compareByteOffToPtrMem` or + -- `compareByteOffToBytesMem`, depending on the nature of @mr@ type. However it differs + -- from the aforementioned functions with a fact that it is pure non-monadic + -- computation. + -- + -- [Unsafe] When any precondition for either of the offsets @memOff1@, @memOff2@ or the + -- element count @memCount@ is violated the result is either unpredictable output or + -- failure with a segfault. + -- + -- @since 0.1.0 + compareByteOffMem :: + (MemRead mr', Prim e) + => mr' -- ^ /memRead1/ - First memory region + -> Off Word8 + -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memOff1 + -- + -- > unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -> mr -- ^ /memRead2/ - Second memory region + -> Off Word8 + -- ^ /memOff2/ - Offset for @memRead2@ in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memOff2 + -- + -- > unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to compare as binary + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unCountBytes memCount + unOff memOff1 <= unCount (byteCountMem memRead1 - byteCountType @e) + -- + -- > unCountBytes memCount + unOff memOff2 <= unCount (byteCountMem memRead2 - byteCountType @e) + -> Ordering + +-- | Type class that can be implemented for a mutable data type that provides direct read +-- and write access to memory +class MemWrite mw where + + -- | Check if two mutable regions refer to the exact same region of memory + -- + -- @since 0.3.0 + isSameMutMem :: mw s -> mw s -> Bool + + -- | Read an element with an offset in number of elements, rather than bytes as it is + -- the case with `readByteOffMutMem`. + -- + -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the + -- result is either unpredictable output or failure with a segfault. + -- + -- @since 0.3.0 + readOffMutMem :: (MonadPrim s m, Prim e) + => mw s -- ^ /memRead/ - Memory region to read an element from + -> Off e + -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= off + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > count <- getByteCountMutMem memRead + -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) + -- + -> m e + readOffMutMem mw off = readByteOffMutMem mw (toByteOff off) + {-# INLINE readOffMutMem #-} + + -- | Read an element with an offset in number of bytes. + -- + -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the + -- result is either unpredictable output or failure with a segfault. + -- + -- @since 0.3.0 + readByteOffMutMem :: (MonadPrim s m, Prim e) + => mw s -- ^ /memRead/ - Memory region to read an element from + -> Off Word8 + -- ^ /off/ - Offset in number of elements from the beginning of @memRead@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= off + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > count <- getByteCountMutMem memRead + -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) + -- + -> m e + + -- | Write an element with an offset in number of elements, rather than bytes as it is + -- the case with `writeByteOffMutMem`. + -- + -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the + -- outcome is either heap corruption or failure with a segfault. + -- + -- @since 0.3.0 + writeOffMutMem :: (MonadPrim s m, Prim e) + => mw s -- ^ /memWrite/ - Memory region to write an element into + -> Off e + -- ^ /off/ - Offset in number of elements from the beginning of @memWrite@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= off + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > count <- getByteCountMutMem memWrite + -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) + -- + -> e -- ^ /elt/ - Element to write + -> m () + writeOffMutMem mw off = writeByteOffMutMem mw (toByteOff off) + {-# INLINE writeOffMutMem #-} + + -- | Write an element with an offset in number of bytes. + -- + -- [Unsafe] Bounds are not checked. When precondition for @off@ argument is violated the + -- outcome is either heap corruption or failure with a segfault. + -- + -- @since 0.3.0 + writeByteOffMutMem :: (MonadPrim s m, Prim e) + => mw s -- ^ /memWrite/ - Memory region to write an element into + -> Off Word8 + -- ^ /off/ - Offset in number of elements from the beginning of @memWrite@ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= off + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > count <- getByteCountMutMem memWrite + -- > unOff (toByteOff off) <= unCount (count - byteCountType @e) + -- + -> e -> m () + + -- | Copy contiguous chunk of memory from the source mutable memory into the target + -- mutable `MBytes`. Source and target /may/ refer to overlapping memory regions. + -- + -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ + -- or the element count @memCount@ is violated a call to this function can result in: + -- copy of data that doesn't belong to @memSource@, heap corruption or failure with + -- a segfault. + -- + -- @since 0.3.0 + moveByteOffToMBytesMutMem :: + (MonadPrim s m, Prim e) + => mw s -- ^ /memSource/ - Source memory from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset in number of bytes into source memory + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOff (toByteOff memSourceOff) <= unCount (sourceByteCount - byteCountType @e) + -> MBytes p s -- ^ /memTarget/ - Target memory into where to copy + -> Off Word8 + -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Both source and target memory regions must have enough memory to perform a copy + -- of @memCount@ elements starting at their respective offsets. For types that also + -- implement `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) + -> m () + + -- | Copy contiguous chunk of memory from the source mutable memory into the target + -- `Ptr`. Source and target /may/ refer to overlapping memory regions. + -- + -- [Unsafe] When any precondition for one of the offsets @memSourceOff@ or + -- @memTargetOff@, a target pointer @memTarget@ or the element count @memCount@ is + -- violated a call to this function can result in: copy of data that doesn't belong to + -- @memSource@, heap corruption or failure with a segfault. + -- + -- @since 0.3.0 + moveByteOffToPtrMutMem :: + (MonadPrim s m, Prim e) + => mw s -- ^ /memSource/ - Source memory from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset in number of bytes into source memory + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOff (toByteOff memSourceOff) <= unCount (sourceByteCount - byteCountType @e) + -> Ptr e + -- ^ /memTarget/ - Target memory into where to copy + -- + -- /__Precondition:__/ + -- + -- Once the pointer is advanced by @memTargetOff@ the next @unCountBytes memCount@ bytes must + -- still belong to the same region of memory @memTargetWrite@ + -> Off Word8 + -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same + -- memory region @memTarget@ + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Both source and target memory regions must have enough memory to perform a copy + -- of @memCount@ elements starting at their respective offsets. For /memSource/ that also + -- implements `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) + -> m () + + -- | Copy contiguous chunk of memory from the read only memory region into the target + -- mutable memory region. Source and target /must not/ refer to the same memory region, + -- otherwise that would imply that the source is not immutable which would be a + -- violation of some other invariant elsewhere in the code. + -- + -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ + -- or the element count @memCount@ is violated a call to this function can result in: + -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with + -- a segfault. + -- + -- @since 0.1.0 + copyByteOffMem :: (MonadPrim s m, MemRead mr, Prim e) + => mr -- ^ /memSourceRead/ - Read-only source memory region from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset into source memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- > unOff memSourceOff <= unCount (byteCountMem memSourceRead - byteCountType @e) + -> mw s -- ^ /memTargetWrite/ - Target mutable memory + -> Off Word8 + -- ^ /memTargetOff/ - Offset into target memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTargetWrite + -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Both source and target memory regions must have enough memory to perform a copy + -- of @memCount@ elements starting at their respective offsets. For @memSourceRead@: + -- + -- > unOff memSourceOff + unCountBytes memCount <= unCount (byteCountMem memSourceRead - byteCountType @e) + -- + -- and for @memTargetWrite@ that also implements `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTargetWrite + -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) + -> m () + + -- | Copy contiguous chunk of memory from a mutable memory region into the target + -- mutable memory region. Source and target /may/ refer to the same memory region. + -- + -- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ + -- or the element count @memCount@ is violated a call to this function can result in: + -- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with + -- a segfault. + -- + -- @since 0.3.0 + moveByteOffMutMem :: (MonadPrim s m, MemWrite mw', Prim e) + => mw' s -- ^ /memSource/ - Source memory from where to copy + -> Off Word8 + -- ^ /memSourceOff/ - Offset in number of bytes into source memory + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOffBytes memSourceOff <= unCount (sourceByteCount - byteCountType @e) + -> mw s -- ^ /memTarget/ - Target memory into where to copy + -> Off Word8 + -- ^ /memTargetOff/ - Offset into target memory in number of bytes + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOffBytes (toByteOff memTargetOff) <= unCount (targetByteCount - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Both source and target memory regions must have enough memory to perform a copy + -- of @memCount@ elements starting at their respective offsets. For types that also + -- implement `MemAlloc` this can be described as: + -- + -- > sourceByteCount <- getByteCountMutMem memSource + -- > unOff memSourceOff + unCountBytes memCount <= unCount (sourceByteCount - byteCountType @e) + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff + unCountBytes memCount <= unCount (targetByteCount - byteCountType @e) + -> m () + + -- TODO: Potential feature for the future implementation. Will require extra function in `Prim`. + --setByteOffMutMem :: (MonadPrim s m, Prim e) => w s -> Off Word8 -> Count e -> e -> m () + + -- | Write the same value @memCount@ times into each cell of @memTarget@ starting at an + -- offset @memTargetOff@. + -- + -- [Unsafe] Bounds are not checked. When precondition for @memTargetOff@ argument is + -- violated the outcome is either heap corruption or failure with a segfault. + -- + -- @since 0.3.0 + setMutMem + :: (MonadPrim s m, Prim e) + => mw s -- ^ /memTarget/ - Target memory into where to write the element + -> Off e + -- ^ /memTargetOff/ - Offset into target memory in number of elements at which element + -- setting should start. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOffBytes memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> Count e + -- ^ /memCount/ - Number of times the element @elt@ should be written + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Target memory region should have enough memory to perform a set operation of the + -- supplied element @memCount@ number of times starting at the supplied offset. For + -- types that also implement `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unCountBytes memCount + unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> e + -- ^ /elt/ - Element to write into memory cells. This function is strict with + -- respect to element, which means that the even @memCount = 0@ it might be still + -- fully evaluated. + -> m () + +-- | Generalized memory allocation and pure/mutable state conversion. +class (MemRead (FrozenMem ma), MemWrite ma) => MemAlloc ma where + -- | Memory region in the immutable state. Types for frozen and thawed states of + -- memory region are in one-to-one correspondence, therefore @ma <-> FrozeMem ma@ will + -- always uniquely identify each other, which is an extremely useful property when it + -- comes to type inference. + type FrozenMem ma = (fm :: Type) | fm -> ma + + -- | Extract the number of bytes a mutable memory region can hold, i.e. what is the + -- total allocated size for this region. The size of a region can be changes and in some + -- circuimstances even in place without copy, see `reallocMutMem` for more info. + -- + -- ====__Examples__ + -- + -- >>> m <- allocMutMem (10 :: Count Int64) :: IO (MBytes 'Pin RW) + -- >>> getByteCountMutMem m + -- Count {unCount = 80} + -- + -- @since 0.3.0 + getByteCountMutMem :: MonadPrim s m => ma s -> m (Count Word8) + + -- | Allocate a mutable memory region for specified number of elements. Memory is not + -- reset and will likely hold some garbage data, therefore prefer to use `allocZeroMutMem`, + -- unless it is guaranteed that all of allocated memory will be overwritten. + -- + -- [Unsafe] When any of preconditions for @memCount@ argument is violated the outcome is + -- unpredictable. One possible outcome is termination with + -- `Control.Exception.HeapOverflow` async exception. In a pure setting, such as when + -- executed within `runST`, if allocated memory is not fully overwritten it can lead to + -- violation of referential transparency, because contents of newly allocated region is + -- non-determinstic. + -- + -- @since 0.3.0 + allocMutMem :: (Prim e, MonadPrim s m) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -- When converted to bytes the value should be less then available physical memory + -> m (ma s) + + -- | Convert the state of an immutable memory region to the mutable one. This is a no + -- copy operation, as such it is fast, but dangerous. See `thawCloneMutMem` for a safe + -- alternative. + -- + -- [Unsafe] This function makes it possible to break referential transparency, because + -- any subsequent destructive operation to the mutable region of memory will also be + -- reflected in the frozen immutable type as well. + -- + -- @since 0.1.0 + thawMem :: MonadPrim s m => FrozenMem ma -> m (ma s) + + -- | Convert the state of a mutable memory region to the immutable one. This is a no + -- copy operation, as such it is fast, but dangerous. See `freezeCopyMem` for a safe alternative. + -- + -- [Unsafe] It makes it possible to break referential transparency, because any + -- subsequent destructive operation to the mutable region of memory will also be + -- reflected in the frozen immutable type as well. + -- + -- @since 0.3.0 + freezeMutMem :: MonadPrim s m => ma s -> m (FrozenMem ma) + + -- | Either grow or shrink currently allocated mutable region of memory. For some + -- implementations it might be possible to change the size of the allocated region + -- in-place, i.e. without copy. However in all implementations there is a good chance + -- that the memory region has to be allocated anew, in which case all of the contents + -- up to the minimum of new and old sizes will get copied over. After the resize + -- operation is complete the supplied @memSource@ region must not be used + -- anymore. Moreover, no reference to the old one should be kept in order to allow + -- garbage collection of the original in case a new one had to be allocated. + -- + -- Default implementation is `defaultReallocMutMem` + -- + -- [Unsafe] Undefined behavior when @memSource@ is used afterwards. The same unsafety + -- notice from `allocMutMem` with regards to @memCount@ is applicable here as well. + -- + -- @since 0.3.0 + reallocMutMem :: (MonadPrim s m, Prim e) + => ma s + -- ^ /memSource/ - Source memory region to resize + -> Count e + -- ^ /memCount/ - Number of elements for the reallocated memory region + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Should be less then available physical memory + -> m (ma s) + reallocMutMem = defaultReallocMutMem + {-# INLINE reallocMutMem #-} + +instance MemRead (UArray e) where + isSameMem = isSameUArray + {-# INLINE isSameMem #-} + byteCountMem = byteCountMem . fromUArrayBytes + {-# INLINE byteCountMem #-} + indexOffMem a = indexOffMem (fromUArrayBytes a) + {-# INLINE indexOffMem #-} + indexByteOffMem a = indexByteOffMem (fromUArrayBytes a) + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem a = copyByteOffToMBytesMem (fromUArrayBytes a) + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem a = copyByteOffToPtrMem (fromUArrayBytes a) + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem a = compareByteOffToPtrMem (fromUArrayBytes a) + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem a = compareByteOffToBytesMem (fromUArrayBytes a) + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem1 off1 a = compareByteOffMem mem1 off1 (fromUArrayBytes a) + {-# INLINE compareByteOffMem #-} + +instance MemWrite (UMArray e) where + isSameMutMem = isSameUMArray + {-# INLINE isSameMutMem #-} + readOffMutMem ma = readOffMutMem (fromUMArrayMBytes ma) + {-# INLINE readOffMutMem #-} + readByteOffMutMem ma = readByteOffMutMem (fromUMArrayMBytes ma) + {-# INLINE readByteOffMutMem #-} + writeOffMutMem ma = writeOffMutMem (fromUMArrayMBytes ma) + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem ma = writeByteOffMutMem (fromUMArrayMBytes ma) + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem ma = moveByteOffToPtrMutMem (fromUMArrayMBytes ma) + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem ma = moveByteOffToMBytesMutMem (fromUMArrayMBytes ma) + {-# INLINE moveByteOffToMBytesMutMem #-} + copyByteOffMem src srcOff ma = copyByteOffMem src srcOff (fromUMArrayMBytes ma) + {-# INLINE copyByteOffMem #-} + moveByteOffMutMem src srcOff ma = moveByteOffMutMem src srcOff (fromUMArrayMBytes ma) + {-# INLINE moveByteOffMutMem #-} + setMutMem ma = setMutMem (fromUMArrayMBytes ma) + {-# INLINE setMutMem #-} + +instance MemAlloc (UMArray e) where + type FrozenMem (UMArray e) = UArray e + getByteCountMutMem = getByteCountMutMem . fromUMArrayMBytes + {-# INLINE getByteCountMutMem #-} + allocMutMem = fmap toUMArrayMBytes . allocUnpinnedMBytes + {-# INLINE allocMutMem #-} + thawMem = fmap toUMArrayMBytes . thawBytes . fromUArrayBytes + {-# INLINE thawMem #-} + freezeMutMem = fmap toUArrayBytes . freezeMBytes . fromUMArrayMBytes + {-# INLINE freezeMutMem #-} + reallocMutMem ma = fmap toUMArrayMBytes . reallocMBytes (fromUMArrayMBytes ma) + {-# INLINE reallocMutMem #-} + + +instance MemRead ByteString where + isSameMem bs1 bs2 = + unsafeInlineIO $ + withPtrAccess bs1 $ \ptr1 -> + withPtrAccess bs2 $ \ptr2 -> -- Can refer to the same memory but sliced differently: + pure (ptr1 == (ptr2 :: Ptr Word8) && BS.length bs1 == BS.length bs2) + {-# INLINE isSameMem #-} + byteCountMem = Count . BS.length + {-# INLINE byteCountMem #-} + indexOffMem bs i = unsafeInlineIO $ withPtrAccess bs (`readOffPtr` i) + {-# INLINE indexOffMem #-} + indexByteOffMem bs i = unsafeInlineIO $ withPtrAccess bs (`readByteOffPtr` i) + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem bs srcOff mb dstOff c = + withPtrAccess bs $ \srcPtr -> + copyByteOffPtrToMBytes srcPtr srcOff mb dstOff c + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem bs srcOff dstPtr dstOff c = + withPtrAccess bs $ \srcPtr -> + copyByteOffPtrToPtr srcPtr srcOff dstPtr dstOff c + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem bs off1 ptr2 off2 c = + withPtrAccess bs $ \ptr1 -> + pure $! compareByteOffPtrToPtr ptr1 off1 ptr2 off2 c + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem bs off1 bytes off2 c = + unsafeInlineIO $ + withPtrAccess bs $ \ptr1 -> + pure $! compareByteOffPtrToBytes ptr1 off1 bytes off2 c + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem1 off1 bs off2 c = + unsafeInlineIO $ + withPtrAccess bs $ \ptr2 -> compareByteOffToPtrMem mem1 off1 ptr2 off2 c + {-# INLINE compareByteOffMem #-} + +instance MemWrite MByteString where + isSameMutMem (MByteString bs1) (MByteString bs2) = isSameMem bs1 bs2 + {-# INLINE isSameMutMem #-} + readOffMutMem (MByteString mbs) i = withPtrAccess mbs (`readOffPtr` i) + {-# INLINE readOffMutMem #-} + readByteOffMutMem (MByteString mbs) i = withPtrAccess mbs (`readByteOffPtr` i) + {-# INLINE readByteOffMutMem #-} + writeOffMutMem (MByteString mbs) i a = withPtrAccess mbs $ \ptr -> writeOffPtr ptr i a + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem (MByteString mbs) i a = withPtrAccess mbs $ \ptr -> writeByteOffPtr ptr i a + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem (MByteString fsrc) srcOff dstPtr dstOff c = + withPtrAccess fsrc $ \srcPtr -> moveByteOffPtrToPtr srcPtr srcOff dstPtr dstOff c + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem (MByteString fsrc) srcOff dst dstOff c = + withPtrAccess fsrc $ \srcPtr -> moveByteOffPtrToMBytes srcPtr srcOff dst dstOff c + {-# INLINE moveByteOffToMBytesMutMem #-} + copyByteOffMem src srcOff (MByteString fdst) dstOff c = + withPtrAccess fdst $ \dstPtr -> copyByteOffToPtrMem src srcOff dstPtr dstOff c + {-# INLINE copyByteOffMem #-} + moveByteOffMutMem src srcOff (MByteString fdst) dstOff c = + withPtrAccess fdst $ \dstPtr -> moveByteOffToPtrMutMem src srcOff dstPtr dstOff c + {-# INLINE moveByteOffMutMem #-} + setMutMem (MByteString mbs) off c a = withPtrAccess mbs $ \ptr -> setOffPtr ptr off c a + {-# INLINE setMutMem #-} + +instance MemAlloc MByteString where + type FrozenMem MByteString = ByteString + getByteCountMutMem (MByteString bs) = pure $! Count (BS.length bs) + {-# INLINE getByteCountMutMem #-} + allocMutMem c = do + let cb = toByteCount c + fp <- mallocByteCountPlainForeignPtr cb + pure $ MByteString (PS fp 0 (coerce cb)) + {-# INLINE allocMutMem #-} + thawMem bs = pure $ MByteString bs + {-# INLINE thawMem #-} + freezeMutMem (MByteString bs) = pure bs + {-# INLINE freezeMutMem #-} + reallocMutMem bsm@(MByteString (PS fp o n)) newc + | newn > n = defaultReallocMutMem bsm newc + | otherwise = pure $ MByteString (PS fp o newn) + where -- constant time slice if we need to reduce the size + Count newn = toByteCount newc + {-# INLINE reallocMutMem #-} + + +instance MemRead T.Array where + isSameMem a1 a2 = isSameMem (T.fromArrayBytes a1) (T.fromArrayBytes a2) + {-# INLINE isSameMem #-} + byteCountMem = byteCountMem . T.fromArrayBytes + {-# INLINE byteCountMem #-} + indexOffMem a = indexOffMem (T.fromArrayBytes a) + {-# INLINE indexOffMem #-} + indexByteOffMem a = indexByteOffMem (T.fromArrayBytes a) + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem a = copyByteOffToMBytesMem (T.fromArrayBytes a) + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem a = copyByteOffToPtrMem (T.fromArrayBytes a) + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem a = compareByteOffToPtrMem (T.fromArrayBytes a) + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem a = compareByteOffToBytesMem (T.fromArrayBytes a) + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem off1 a = compareByteOffMem mem off1 (T.fromArrayBytes a) + {-# INLINE compareByteOffMem #-} + +instance MemAlloc T.MArray where + type FrozenMem T.MArray = T.Array + getByteCountMutMem = getByteCountMBytes . T.fromMArrayMBytes + {-# INLINE getByteCountMutMem #-} + allocMutMem = fmap T.toMArrayMBytes . allocUnpinnedMBytes + {-# INLINE allocMutMem #-} + thawMem = fmap T.toMArrayMBytes . thawBytes . T.fromArrayBytes + {-# INLINE thawMem #-} + freezeMutMem = fmap T.toArrayBytes . freezeMBytes . T.fromMArrayMBytes + {-# INLINE freezeMutMem #-} + reallocMutMem m = fmap T.toMArrayMBytes . reallocMBytes (T.fromMArrayMBytes m) + {-# INLINE reallocMutMem #-} + +instance MemWrite T.MArray where + isSameMutMem ma1 ma2 = isSameMutMem (T.fromMArrayMBytes ma1) (T.fromMArrayMBytes ma2) + {-# INLINE isSameMutMem #-} + readOffMutMem m = readOffMBytes (T.fromMArrayMBytes m) + {-# INLINE readOffMutMem #-} + readByteOffMutMem m = readByteOffMBytes (T.fromMArrayMBytes m) + {-# INLINE readByteOffMutMem #-} + writeOffMutMem m = writeOffMBytes (T.fromMArrayMBytes m) + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem m = writeByteOffMBytes (T.fromMArrayMBytes m) + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem m = moveByteOffMBytesToPtr (T.fromMArrayMBytes m) + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem m = moveByteOffMBytesToMBytes (T.fromMArrayMBytes m) + {-# INLINE moveByteOffToMBytesMutMem #-} + moveByteOffMutMem src srcOff m = moveByteOffToMBytesMutMem src srcOff (T.fromMArrayMBytes m) + {-# INLINE moveByteOffMutMem #-} + copyByteOffMem src srcOff m = copyByteOffToMBytesMem src srcOff (T.fromMArrayMBytes m) + {-# INLINE copyByteOffMem #-} + setMutMem m = setMBytes (T.fromMArrayMBytes m) + {-# INLINE setMutMem #-} + +instance MemRead T.Text where + isSameMem (T.Text a1 o1 n1) (T.Text a2 o2 n2) = isSameMem a1 a2 && o1 == o2 && n1 == n2 + {-# INLINE isSameMem #-} + byteCountMem (T.Text _ _ n) = toByteCount (Count n :: Count Word16) + {-# INLINE byteCountMem #-} + indexByteOffMem (T.Text a o _) i = indexByteOffMem a (toByteOff (Off o :: Off Word16) + i) + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem (T.Text a o _) i = + copyByteOffToMBytesMem a (toByteOff (Off o :: Off Word16) + i) + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem (T.Text a o _) i = + copyByteOffToPtrMem a (toByteOff (Off o :: Off Word16) + i) + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem (T.Text a o _) off = + compareByteOffToPtrMem a (toByteOff (Off o :: Off Word16) + off) + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem (T.Text a o _) off = + compareByteOffToBytesMem a (toByteOff (Off o :: Off Word16) + off) + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem off1 (T.Text a o _) off2 = + compareByteOffMem mem off1 a (toByteOff (Off o :: Off Word16) + off2) + {-# INLINE compareByteOffMem #-} + + +instance MemRead ShortByteString where + isSameMem sbs1 sbs2 = isSameMem (fromShortByteStringBytes sbs1) (fromShortByteStringBytes sbs2) + {-# INLINE isSameMem #-} + byteCountMem = byteCountMem . fromShortByteStringBytes + {-# INLINE byteCountMem #-} + indexOffMem sbs = indexOffMem (fromShortByteStringBytes sbs) + {-# INLINE indexOffMem #-} + indexByteOffMem sbs = indexByteOffMem (fromShortByteStringBytes sbs) + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem sbs = copyByteOffToMBytesMem (fromShortByteStringBytes sbs) + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem sbs = copyByteOffToPtrMem (fromShortByteStringBytes sbs) + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem sbs = compareByteOffToPtrMem (fromShortByteStringBytes sbs) + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem sbs = compareByteOffToBytesMem (fromShortByteStringBytes sbs) + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem off1 sbs = compareByteOffMem mem off1 (fromShortByteStringBytes sbs) + {-# INLINE compareByteOffMem #-} + +-- | A wrapper that adds a phantom state token. It can be used with types that either +-- don't have such state token or are designed to work in `IO` and therefore restricted +-- to `RealWorld`. Using this wrapper is very much unsafe, so make sure you know what you are +-- doing. +newtype MemState a s = MemState { unMemState :: a } + +instance MemWrite (MemState (ForeignPtr a)) where + isSameMutMem (MemState fptr1) (MemState fptr2) = + unsafeInlineIO $ + withPtrAccess fptr1 $ \ptr1 -> + withPtrAccess fptr2 $ \ptr2 -> + pure (ptr1 == (ptr2 :: Ptr Word8)) + {-# INLINE isSameMutMem #-} + readOffMutMem (MemState fptr) i = withForeignPtr fptr $ \ptr -> readOffPtr (castPtr ptr) i + {-# INLINE readOffMutMem #-} + readByteOffMutMem (MemState fptr) i = + withForeignPtr fptr $ \ptr -> readByteOffPtr (castPtr ptr) i + {-# INLINE readByteOffMutMem #-} + writeOffMutMem (MemState fptr) i a = withForeignPtr fptr $ \ptr -> writeOffPtr (castPtr ptr) i a + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem (MemState fptr) i a = + withForeignPtr fptr $ \ptr -> writeByteOffPtr (castPtr ptr) i a + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem (MemState fsrc) srcOff dstPtr dstOff c = + withForeignPtr fsrc $ \srcPtr -> moveByteOffPtrToPtr (castPtr srcPtr) srcOff dstPtr dstOff c + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem (MemState fsrc) srcOff dst dstOff c = + withForeignPtr fsrc $ \srcPtr -> moveByteOffPtrToMBytes (castPtr srcPtr) srcOff dst dstOff c + {-# INLINE moveByteOffToMBytesMutMem #-} + copyByteOffMem src srcOff (MemState fdst) dstOff c = + withForeignPtr fdst $ \dstPtr -> + copyByteOffToPtrMem src srcOff (castPtr dstPtr) dstOff c + {-# INLINE copyByteOffMem #-} + moveByteOffMutMem src srcOff (MemState fdst) dstOff c = + withForeignPtr fdst $ \dstPtr -> + moveByteOffToPtrMutMem src srcOff (castPtr dstPtr) dstOff c + {-# INLINE moveByteOffMutMem #-} + setMutMem (MemState fptr) off c a = withForeignPtr fptr $ \ptr -> setOffPtr (castPtr ptr) off c a + {-# INLINE setMutMem #-} + +-- +-- @since 0.3.0 +modifyFetchOldMutMem :: + (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> e) -> m e +modifyFetchOldMutMem mem o f = modifyFetchOldMutMemM mem o (pure . f) +{-# INLINE modifyFetchOldMutMem #-} + + +-- +-- @since 0.3.0 +modifyFetchNewMutMem :: + (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> e) -> m e +modifyFetchNewMutMem mem o f = modifyFetchNewMutMemM mem o (pure . f) +{-# INLINE modifyFetchNewMutMem #-} + + +-- +-- @since 0.3.0 +modifyFetchOldMutMemM :: + (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> m e) -> m e +modifyFetchOldMutMemM mem o f = do + a <- readOffMutMem mem o + a <$ (writeOffMutMem mem o =<< f a) +{-# INLINE modifyFetchOldMutMemM #-} + + +-- +-- @since 0.3.0 +modifyFetchNewMutMemM :: + (MemWrite mw, MonadPrim s m, Prim e) => mw s -> Off e -> (e -> m e) -> m e +modifyFetchNewMutMemM mem o f = do + a <- readOffMutMem mem o + a' <- f a + a' <$ writeOffMutMem mem o a' +{-# INLINE modifyFetchNewMutMemM #-} + +-- | An action that can be used as a default implementation for `reallocMutMem`. Whenever +-- current memory region byte count matches the supplied new size exactly then such memory +-- region is simply returned back and this function is a noop. Otherwise a new memory +-- region is allocated and all the data that can fit into the new region will be copied +-- over. +-- +-- [Unsafe] Same unsafety notice as in `reallocMutMem` +-- +-- @since 0.3.0 +defaultReallocMutMem :: + (Prim e, MemAlloc ma, MonadPrim s m) => ma s -> Count e -> m (ma s) +defaultReallocMutMem mem c = do + let newByteCount = toByteCount c + oldByteCount <- getByteCountMutMem mem + if oldByteCount == newByteCount + then pure mem + else do + newMem <- allocMutMem newByteCount + oldMem <- freezeMutMem mem + newMem <$ copyMem oldMem 0 newMem 0 (min oldByteCount newByteCount) +{-# INLINE defaultReallocMutMem #-} + + +-- | Place @n@ copies of supplied region of memory one after another in a newly allocated +-- contiguous chunk of memory. Similar to `stimes`, but the source memory @memRead@ does +-- not have to match the type of `FrozenMem` ma. +-- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> let b = fromListMem @Word8 @(MBytes 'Inc) [0xde, 0xad, 0xbe, 0xef] +-- >>> cycleMemN @(MBytes 'Inc) 2 b +-- [0xde,0xad,0xbe,0xef,0xde,0xad,0xbe,0xef] +-- +-- @since 0.1.0 +cycleMemN :: + forall ma mr. (MemAlloc ma, MemRead mr) + => Int + -> mr + -> FrozenMem ma +cycleMemN n r + | n <= 0 = emptyMem + | otherwise = + runST $ do + let bc@(Count chunk) = byteCountMem r + c@(Count c8) = Count n * bc + mem <- allocMutMem c + let go i = when (i < c8) $ copyByteOffMem r 0 mem (Off i) bc >> go (i + chunk) + go 0 + freezeMutMem mem +{-# INLINE cycleMemN #-} + + +-- | Construct an immutable memory region that can't hold any data. Same as @`mempty` :: +-- `FrozenMem` ma@ +-- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> toListMem (emptyMem @(MBytes 'Inc)) :: [Int] +-- [] +-- +-- @since 0.1.0 +emptyMem :: + forall ma. MemAlloc ma + => FrozenMem ma +emptyMem = createMemST_ (0 :: Count Word8) (\_ -> pure ()) +{-# INLINE emptyMem #-} + +-- | Allocate a region of immutable memory that holds a single element. +-- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> toListMem (singletonMem @Word16 @(MBytes 'Inc) 0xffff) :: [Word8] +-- [255,255] +-- +-- @since 0.1.0 +singletonMem :: + forall e ma. (MemAlloc ma, Prim e) + => e -- ^ The single element that will be stored in the newly allocated region of memory + -> FrozenMem ma +singletonMem a = createMemST_ (1 :: Count e) $ \mem -> writeOffMutMem mem 0 a +{-# INLINE singletonMem #-} + +-- | Same as `allocMutMem`, but also use `setMutMem` to reset all of newly allocated memory to +-- zeros. +-- +-- [Unsafe] When precondition for @memCount@ argument is violated the outcome is +-- unpredictable. One possible outcome is termination with `Control.Exception.HeapOverflow` +-- async exception. +-- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> mb <- allocZeroMutMem @Int @(MBytes 'Inc) 10 +-- >>> b <- freezeMutMem mb +-- >>> toListMem b :: [Int] +-- [0,0,0,0,0,0,0,0,0,0] +-- +-- @since 0.3.0 +allocZeroMutMem :: + forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -- When converted to bytes the value should be less then available physical memory + -> m (ma s) +allocZeroMutMem n = do + m <- allocMutMem n + m <$ setMutMem m 0 (toByteCount n) (0 :: Word8) +{-# INLINE allocZeroMutMem #-} + +-- | Allocate a mutable region of memory and fill it with the supplied `ST` action. Besides +-- the newly filled frozen memory this function also returns the result produced by the +-- filling action. See `createMemST_` for the version that discards it. Also see +-- `createZeroMemST` for a safer alternative. +-- +-- [Unsafe] Same caviats as in `allocMutMem` +-- +-- @since 0.1.0 +createMemST :: + forall e b ma. (MemAlloc ma, Prim e) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -- When converted to bytes the value should be less then available physical memory + -> (forall s. ma s -> ST s b) + -- ^ /memFillAction/ - This action will be used to modify the contents of newly + -- allocated memory. Make sure to overwrite all of it, otherwise it might lead to + -- breaking referential transparency. + -> (b, FrozenMem ma) +createMemST n f = runST $ allocMutMem n >>= \m -> (,) <$> f m <*> freezeMutMem m +{-# INLINE createMemST #-} + + +createMemST_ :: + (MemAlloc ma, Prim e) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -- When converted to bytes the value should be less then available physical memory + -> (forall s. ma s -> ST s b) + -- ^ /memFillAction/ - This action will be used to modify the contents of newly + -- allocated memory. Make sure to overwrite all of it, otherwise it might lead to + -- breaking referential transparency. + -> FrozenMem ma +createMemST_ n f = runST (allocMutMem n >>= \m -> f m >> freezeMutMem m) +{-# INLINE createMemST_ #-} + +-- | Same as `createMemST`, except it in ensures that the memory is reset to zeros right +-- after allocation +-- +-- [Unsafe] Same caviats as in `allocZeroMutMem`: violation of precondition for @memCount@ may +-- result in undefined behavior or `Control.Exception.HeapOverflow` async exception. +-- +-- @since 0.1.0 +createZeroMemST :: + forall e ma b. (MemAlloc ma, Prim e) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -- When converted to bytes the value should be less then available physical memory + -> (forall s. ma s -> ST s b) + -- ^ /fillAction/ -- Action that will be used to modify contents of newly allocated + -- memory. It is not required to overwrite the full region, since the whole thing will + -- be reset to zeros before applying this action. + -> (b, FrozenMem ma) +createZeroMemST n f = runST $ allocZeroMutMem n >>= \m -> (,) <$> f m <*> freezeMutMem m +{-# INLINE createZeroMemST #-} + +-- | Same as `createMemST_`, except it ensures that the memory gets reset with zeros right +-- after allocation and prior applying the @ST@ filling action @fillAction@. +-- +-- [Unsafe] Same reasons as `allocZeroMutMem`: violation of precondition for @memCount@ may +-- result in undefined behavior or `Control.Exception.HeapOverflow` async exception. +-- +-- ====__Example__ +-- +-- Note that this example will work correctly only on little-endian machines: +-- +-- >>> :set -XTypeApplications +-- >>> import Data.Prim +-- >>> import Control.Monad +-- >>> let ibs = zip [0, 4 ..] [0x48,0x61,0x73,0x6b,0x65,0x6c,0x6c] :: [(Off Word8, Word8)] +-- >>> let c = Count (length ibs) :: Count Char +-- >>> let bc = createZeroMemST_ @_ @(MBytes 'Inc) c $ \m -> forM_ ibs $ \(i, b) -> writeByteOffMutMem m i b +-- >>> toListMem bc :: String +-- "Haskell" +-- +-- @since 0.1.0 +createZeroMemST_ :: + forall e ma b. (MemAlloc ma, Prim e) + => Count e + -- ^ /memCount/ - Amount of memory to allocate for the region in number of elements of + -- type __@e@__ + -- + -- /__Precoditions:__/ + -- + -- Size should be non-negative, but smaller than amount of available memory. Note that the + -- second condition simply describes overflow. + -- + -- > 0 <= memCount + -- + -- Possibility of overflow: + -- + -- > memCount <= fromByteCount maxBound + -- + -> (forall s. ma s -> ST s b) + -- ^ /fillAction/ -- Action that will be used to modify contents of newly allocated + -- memory. It is not required to overwrite the full region, since the whole thing will + -- be reset to zeros before applying this action. + -> FrozenMem ma +createZeroMemST_ n f = runST (allocZeroMutMem n >>= \m -> f m >> freezeMutMem m) +{-# INLINE createZeroMemST_ #-} + +-- | Copy all of the data from the source into a newly allocate memory region of identical +-- size. +-- +-- ====__Examples__ +-- +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> import Data.Prim.Memory.Bytes +-- >>> let xs = fromByteListMem @(MBytes 'Pin) [0..15] :: Bytes 'Pin +-- >>> let ys = cloneMem xs +-- >>> let report bEq pEq = print $ "Bytes equal: " ++ show bEq ++ ", their pointers equal: " ++ show pEq +-- >>> withPtrBytes xs $ \ xsPtr -> withPtrBytes ys $ \ ysPtr -> report (xs == ys) (xsPtr == ysPtr) +-- "Bytes equal: True, their pointers equal: False" +-- >>> report (eqByteMem xs ys) (isSameBytes xs ys) +-- "Bytes equal: True, their pointers equal: False" +-- +-- @since 0.2.0 +cloneMem :: + forall ma. MemAlloc ma + => FrozenMem ma -- ^ /memSource/ - immutable source memory. + -> FrozenMem ma +cloneMem fm = + runST $ do + let n = byteCountMem fm + mm <- allocMutMem n + copyMem fm 0 mm 0 n + freezeMutMem mm +{-# INLINE cloneMem #-} + +-- | Similar to `copyByteOffMem`, but supply offsets in number of elements instead of +-- bytes. Copy contiguous chunk of memory from the read only memory region into the target +-- mutable memory region. Source and target /must not/ refer to the same memory region, +-- otherwise that would imply that the source is not immutable which would be a violation +-- of some other invariant elsewhere in the code. +-- +-- [Unsafe] When any precondition for one of the offsets @memSourceOff@, @memTargetOff@ +-- or the element count @memCount@ is violated a call to this function can result in: +-- copy of data that doesn't belong to @memSourceRead@, heap corruption or failure with +-- a segfault. +-- +-- @since 0.1.0 +copyMem :: + (MonadPrim s m, MemRead mr, MemWrite mw, Prim e) + => mr -- ^ /memSourceRead/ - Read-only source memory region from which the data will + -- copied + -> Off e + -- ^ /memSourceOff/ - Offset into source memory in number of elements of type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- > unOff memSourceOff < unCount (countMem memSourceRead) + -> mw s -- ^ /memTargetWrite/ - Target mutable memory + -> Off e + -- ^ /memTargetOff/ - Offset into target memory in number of elements + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- With offset applied it should still refer to the same memory region. For types that + -- also implement `MemAlloc` this can be described as: + -- + -- > targetCount <- getCountMutMem memTargetWrite + -- > unOff memTargetOff < unCount targetCount + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Both source and target memory regions must have enough memory to perform a copy + -- of @memCount@ elements starting at their respective offsets. For @memSourceRead@: + -- + -- > unOff memSourceOff + unCount memCount < unCount (countMem memSourceRead) + -- + -- and for @memTargetWrite@ that also implements `MemAlloc` this can be described as: + -- + -- > targetCount <- getCountMutMem memTargetWrite + -- > unOff memTargetOff + unCount memCount < unCount targetCount + -> m () +copyMem src srcOff dst dstOff = copyByteOffMem src (toByteOff srcOff) dst (toByteOff dstOff) +{-# INLINE copyMem #-} + + +-- +-- @since 0.3.0 +moveMutMem :: + (MonadPrim s m, MemWrite mw1, MemWrite mw2, Prim e) + => mw1 s -- ^ Source memory region + -> Off e -- ^ Offset into the source in number of elements + -> mw2 s -- ^ Destination memory region + -> Off e -- ^ Offset into destination in number of elements + -> Count e -- ^ Number of elements to copy over + -> m () +moveMutMem src srcOff dst dstOff = moveByteOffMutMem src (toByteOff srcOff) dst (toByteOff dstOff) +{-# INLINE moveMutMem #-} + + +appendMem :: + forall mr1 mr2 ma. (MemRead mr1, MemRead mr2, MemAlloc ma) + => mr1 + -> mr2 + -> FrozenMem ma +appendMem r1 r2 = + createMemST_ (n1 + n2) $ \mem -> do + copyMem r1 0 mem 0 n1 + copyMem r2 (coerce n1) mem (coerce n1) n2 + where + n1 = byteCountMem r1 + n2 = byteCountMem r2 +{-# INLINABLE appendMem #-} + +concatMem :: + forall mr ma. (MemRead mr, MemAlloc ma) + => [mr] + -> FrozenMem ma +concatMem xs = do + let c = Foldable.foldl' (\ !acc b -> acc + byteCountMem b) 0 xs + createMemST_ c $ \mb -> do + let load i b = do + let cb@(Count n) = byteCountMem b :: Count Word8 + (i + Off n) <$ copyMem b 0 mb i cb + foldM_ load 0 xs +{-# INLINABLE concatMem #-} + +-- | This is a safe version of `thawMem`. It first makes an exact copy of the supplied +-- memory region and only then thaws it, thus yielding a mutable region of memory. This +-- means any mutation, will only affect the newly allocated region that was returned and +-- not the source region. +-- +-- ====__Examples__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> let fm = fromListMem @Word8 @(MBytes 'Inc) [1,2,3,4] +-- >>> mm <- thawCloneMem fm +-- >>> writeOffMutMem mm 1 (0xadde :: Word16) +-- >>> freezeMutMem mm +-- [0x01,0x02,0xde,0xad] +-- >>> fm +-- [0x01,0x02,0x03,0x04] +-- +-- @since 0.1.0 +thawCloneMem :: + forall ma m s. (MemAlloc ma, MonadPrim s m) + => FrozenMem ma + -> m (ma s) +thawCloneMem a = thawCopyMem a 0 (byteCountMem a) +{-# INLINE thawCloneMem #-} + + +-- | Similar to `thawCloneMem`, except it is possible to specify which portion of the +-- frozen region will be copied over and thawed. +-- +-- [Unsafe] When any precondition for eihter an offset @memSourceOff@ or the element count +-- @memCount@ is violated a call to this function can result in: copy of data that doesn't +-- belong to @memSource@ or failure with a segfault. +-- +-- ====__Examples__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> let fm = fromListMem @Word8 @(MBytes 'Inc) [1,2,3,4,5] +-- >>> mm <- thawCopyMem fm 1 (3 :: Count Word8) +-- >>> writeOffMutMem mm 1 (0 :: Word8) +-- >>> freezeMutMem mm +-- [0x02,0x00,0x04] +-- >>> fm +-- [0x01,0x02,0x03,0x04,0x05] +-- +-- @since 0.1.0 +thawCopyMem :: + forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) + => FrozenMem ma -- ^ /memSource/ - Read-only source memory region from which the data + -- will copied and thawed + -> Off e + -- ^ /memSourceOff/ - Offset into source memory in number of elements of type __@e@__ + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memSourceOff + -- + -- > unOff memSourceOff < unCount (countMem memSource) + -> Count e + -- ^ /memCount/ - Number of elements of type __@e@__ to copy + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > unOff memSourceOff + unCount memCount < unCount (countMem memSource) + -> m (ma s) +thawCopyMem a off c = do + mem <- allocMutMem c + mem <$ copyMem a off mem 0 c +{-# INLINE thawCopyMem #-} + + + +-- +-- @since 0.3.0 +freezeCopyMutMem :: + forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) + => ma s + -> Off e + -> Count e + -> m (FrozenMem ma) +freezeCopyMutMem mem off c = freezeMutMem mem >>= \r -> thawCopyMem r off c >>= freezeMutMem +{-# INLINE freezeCopyMutMem #-} + +-- | Safe version of `freezeMutMem`. Yields an immutable copy of the supplied mutable +-- memory region. Further mutation of the source memory region will not affect the +-- produced copy. +--- +-- ====__Example__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> mb <- allocZeroMutMem @Word8 @(MBytes 'Pin) 4 +-- >>> writeOffMutMem mb 2 (0xff :: Word8) +-- >>> b <- freezeCloneMutMem mb +-- >>> writeOffMutMem mb 1 (0xab :: Word8) +-- >>> b +-- [0x00,0x00,0xff,0x00] +-- >>> freezeMutMem mb +-- [0x00,0xab,0xff,0x00] +-- +-- @since 0.3.0 +freezeCloneMutMem :: + forall ma m s. (MemAlloc ma, MonadPrim s m) + => ma s + -> m (FrozenMem ma) +freezeCloneMutMem = freezeMutMem >=> thawCloneMem >=> freezeMutMem +{-# INLINE freezeCloneMutMem #-} + +-- | /O(n)/ - Convert a read-only memory region into a newly allocated other type of +-- memory region +-- +-- >>> import Data.ByteString (pack) +-- >>> let bs = pack [0x10 .. 0x20] +-- >>> bs +-- "\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US " +-- >>> convertMem bs :: Bytes 'Inc +-- [0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20] +-- +-- @since 0.1.0 +convertMem :: (MemRead mr, MemAlloc ma) => mr -> FrozenMem ma +convertMem m = + let c = byteCountMem m + in createMemST_ c (\mm -> copyMem m 0 mm 0 c) +{-# INLINE convertMem #-} + +-- | Figure out how many elements fits into the immutable region of memory. It is +-- possible that there is a remainder of bytes left, see `countRemMem` for getting that +-- too. +-- +-- ====__Examples__ +-- +-- >>> let b = fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin +-- >>> b +-- [0x00,0x01,0x02,0x03,0x04,0x05] +-- >>> countMem b :: Count Word16 +-- Count {unCount = 3} +-- >>> countMem b :: Count Word32 +-- Count {unCount = 1} +-- >>> countMem b :: Count Word64 +-- Count {unCount = 0} +-- +-- @since 0.1.0 +countMem :: + forall e mr. (MemRead mr, Prim e) + => mr + -> Count e +countMem = fromByteCount . byteCountMem +{-# INLINE countMem #-} + +-- | Figure out how many elements and a byte size remainder can fit into the immutable +-- region of memory. +-- +-- ====__Examples__ +-- +-- >>> let b = fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin +-- >>> b +-- [0x00,0x01,0x02,0x03,0x04,0x05] +-- >>> countRemMem @Word16 b +-- (Count {unCount = 3},Count {unCount = 0}) +-- >>> countRemMem @Word32 b +-- (Count {unCount = 1},Count {unCount = 2}) +-- >>> countRemMem @Word64 b +-- (Count {unCount = 0},Count {unCount = 6}) +-- +-- @since 0.1.0 +countRemMem :: forall e mr. (MemRead mr, Prim e) => mr -> (Count e, Count Word8) +countRemMem = fromByteCountRem . byteCountMem +{-# INLINE countRemMem #-} + +-- | Figure out how many elements fits into the mutable region of memory. Similar to +-- `countMem`, except that it is not a pure funciton, since the size of mutable memory can +-- change throuhout its lifetime. It is possible that there is a remainder of bytes left, +-- see `getCountRemMem` for getting that too. +-- +-- ====__Examples__ +-- +-- >>> mb <- thawMem (fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin) +-- >>> getCountMutMem mb :: IO (Count Word16) +-- Count {unCount = 3} +-- >>> getCountMutMem mb :: IO (Count Word32) +-- Count {unCount = 1} +-- >>> getCountMutMem mb :: IO (Count Word64) +-- Count {unCount = 0} +-- >>> mb' <- reallocMutMem mb (6 :: Count Word64) +-- >>> getCountMutMem mb' :: IO (Count Word32) +-- Count {unCount = 12} +-- +-- @since 0.3.0 +getCountMutMem :: forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) => ma s -> m (Count e) +getCountMutMem = fmap (fromByteCount . coerce) . getByteCountMutMem +{-# INLINE getCountMutMem #-} + + +-- | Figure out how many elements and a byte size remainder can fit into the mutable +-- region of memory. Similar to `countRemMem`, except it is a monadic action for mutable +-- regions instead of a pure function for immutable memory. See `getCountMutMem` for getting +-- the element count only. +-- +-- ====__Examples__ +-- +-- >>> b <- thawMem (fromListMem [0 .. 5 :: Word8] :: Bytes 'Pin) +-- >>> getCountRemMutMem @Word16 b +-- (Count {unCount = 3},Count {unCount = 0}) +-- >>> getCountRemMutMem @Word32 b +-- (Count {unCount = 1},Count {unCount = 2}) +-- >>> getCountRemMutMem @Word64 b +-- (Count {unCount = 0},Count {unCount = 6}) +-- +-- @since 0.3.0 +getCountRemMutMem :: + forall e ma m s. (MemAlloc ma, MonadPrim s m, Prim e) + => ma s + -> m (Count e, Count Word8) +getCountRemMutMem = fmap (fromByteCountRem . coerce) . getByteCountMutMem +{-# INLINE getCountRemMutMem #-} + +-- | Allocate the same amount of memory as the source memory region and copy all of its +-- data over. +-- +-- @since 0.3.0 +cloneMutMem :: + forall ma m s. (MemAlloc ma, MonadPrim s m) + => ma s + -> m (ma s) +cloneMutMem = freezeMutMem >=> thawCloneMem +{-# INLINE cloneMutMem #-} + +-- | Compare two memory regions byte-by-byte. Computation may be short-circuited on the +-- first mismatch, but it is `MemRead` implementation specific. +-- +-- @since 0.3.0 +eqByteOffMem :: + (MemRead mr1, MemRead mr2) + => mr1 -- ^ /memRead1/ - First region of memory + -> Off Word8 + -- ^ /memOff1/ - Offset for @memRead1@ in number of bytes + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff1 + -> mr2 -- ^ /memRead2/ - Second region of memory + -> Off Word8 + -- ^ /memOff2/ - Offset for @memRead1@ in number of bytes + -- + -- /__Precondition:__/ + -- + -- > 0 <= memOff2 + -> Count Word8 + -- ^ /memCount/ - Number of bytes compare + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- > offToCount memOff1 + memCount < countMem memRead1 + -- + -- > offToCount memOff2 + memCount < countMem memRead2 + -> Bool +eqByteOffMem b1 off1 b2 off2 n = compareByteOffMem b1 off1 b2 off2 n == EQ +{-# INLINE eqByteOffMem #-} + +-- | Compare two memory regions for equality byte-by-byte. `False` is returned immediately +-- when sizes reported by `byteCountMem` do not match. +-- +-- @since 0.3.0 +eqByteMem :: (MemRead mr1, MemRead mr2) => mr1 -> mr2 -> Bool +eqByteMem b1 b2 = n == byteCountMem b2 && eqByteOffMem b1 0 b2 0 n + where + n = byteCountMem b1 +{-# INLINE eqByteMem #-} + + +-- | Compare two memory regions byte-by-byte. +-- +-- @since 0.3.0 +compareByteMem :: (MemRead mr1, MemRead mr2) => mr1 -> mr2 -> Ordering +compareByteMem b1 b2 = compare n (byteCountMem b2) <> compareByteOffMem b1 0 b2 0 n + where + n = byteCountMem b1 +{-# INLINE compareByteMem #-} + +-- =============== -- +-- List conversion -- +-- =============== -- + +------------- +-- To List -- +------------- + +-- | Convert an immutable memory region to a list. Whenever memory byte count is not +-- exactly divisible by the size of the element there will be some slack left unaccounted +-- for. In order to get a hold of this slack use `toListSlackMem` instead. +-- +-- ====__Examples__ +-- +-- >>> import Data.Prim.Memory +-- >>> import Numeric (showHex) +-- >>> let b = fromByteListMem [0x48,0x61,0x73,0x6b,0x65,0x6c,0x6c] :: Bytes 'Inc +-- >>> toListMem b :: [Int8] +-- [72,97,115,107,101,108,108] +-- >>> let xs = toListMem b :: [Word32] +-- >>> xs +-- [1802723656] +-- >>> showHex (head xs) "" +-- "6b736148" +-- +-- @since 0.1.0 +toListMem :: forall e mr. (MemRead mr, Prim e) => mr -> [e] +toListMem ba = build (\ c n -> foldrCountMem (countMem ba) c n ba) +{-# INLINE toListMem #-} +{-# SPECIALIZE toListMem :: Prim e => Bytes p -> [e] #-} + +-- | Same as `toListMem`, except when there is some slack towards the end of the memory +-- region that didn't fit into a list it will be returned as a list of bytes. +-- +-- ====__Examples__ +-- +-- >>> import Data.Word +-- >>> :set -XDataKinds +-- >>> let a = fromListMem [0 .. 10 :: Word8] :: Bytes 'Pin +-- >>> a +-- [0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] +-- >>> toListSlackMem a :: ([Word8], [Word8]) +-- ([0,1,2,3,4,5,6,7,8,9,10],[]) +-- >>> toListSlackMem a :: ([Word16], [Word8]) +-- ([256,770,1284,1798,2312],[10]) +-- >>> toListSlackMem a :: ([Word32], [Word8]) +-- ([50462976,117835012],[8,9,10]) +-- >>> toListSlackMem a :: ([Word64], [Word8]) +-- ([506097522914230528],[8,9,10]) +-- +-- @since 0.1.0 +toListSlackMem :: + forall e mr. (MemRead mr, Prim e) + => mr + -> ([e], [Word8]) +toListSlackMem mem = + (build (\c n -> foldrCountMem k c n mem), getSlack (k8 + r8) []) + where + (k, Count r8) = countRemMem mem + Count k8 = toByteCount k + getSlack i !acc + | i == k8 = acc + | otherwise = + let i' = i - 1 + in getSlack i' (indexByteOffMem mem (Off i') : acc) +{-# INLINABLE toListSlackMem #-} + +-- | Right fold that is useful for converting to a list while tapping into list fusion. +-- +-- [Unsafe] Supplying Count larger than memory holds will result in reading out of bounds +-- and a potential segfault. +-- +-- @since 0.1.0 +foldrCountMem :: forall e b mr. (MemRead mr, Prim e) => Count e -> (e -> b -> b) -> b -> mr -> b +foldrCountMem (Count k) c nil bs = go 0 + where + go i + | i == k = nil + | otherwise = + let !v = indexOffMem bs (Off i) + in v `c` go (i + 1) +{-# INLINE[0] foldrCountMem #-} + +--------------- +-- From List -- +--------------- + +-- Pure immutable conversion -- + +-- | Just like `fromListMemN`, except it ensures safety by using the length of the +-- list for allocation. Because it has to figure out the length of the list first it +-- will be just a little bit slower, but that much safer. +-- +-- ====__Examples__ +-- +-- >>> import Data.Prim.Memory +-- >>> :set -XDataKinds +-- >>> fromListMem "Hi" :: Bytes 'Inc +-- [0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00] +-- +-- @since 0.1.0 +fromListMem :: + forall e ma. (Prim e, MemAlloc ma) + => [e] + -> FrozenMem ma +fromListMem xs = + let count = coerce (length xs) `countForProxyTypeOf` xs + in createMemST_ count (loadListMutMemN_ count xs) +{-# INLINE fromListMem #-} + + +-- | Same as `fromListMem` but restricted to a list of `Word8`. Load a list of bytes into +-- a newly allocated memory region. Equivalent to `Data.ByteString.pack` for +-- `Data.ByteString.ByteString` +-- +-- ====__Examples__ +-- +-- >>> fromByteListMem [0..10] :: Bytes 'Pin +-- [0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] +-- +-- @since 0.1.0 +fromByteListMem :: + forall ma. MemAlloc ma + => [Word8] + -> FrozenMem ma +fromByteListMem = fromListMem +{-# INLINE fromByteListMem #-} + + +-- | Similarly to `fromListMem` load a list into a newly allocated memory region, but +-- unlike the aforementioned function it also accepts a hint of how many elements is +-- expected to be in the list. Because the number of expected an actual elements might +-- not match we return not only the frozen memory region, but also: +-- +-- * either a list with leftover elements from the input @list@, if it did not fully fit +-- into the allocated region. An empty list would indicate that it did fit exactly. +-- +-- @ +-- unCount memCount <= length list +-- @ +-- +-- * or an exact count of how many elements have been loaded when there was no +-- enough elements in the list +-- +-- +-- In the latter case a zero value would indicate that the list did fit into the newly +-- allocated memory region exactly, which is perfectly fine. But a positive value would +-- mean that the tail of the memory region is still unset and might contain garbage +-- data. Make sure to overwrite the surplus memory yourself or use the safe version +-- `fromListZeroMemN` that fills the surplus with zeros. +-- +-- [Unsafe] Whenever @memCount@ precodition is violated, because on each call with the +-- same input it can produce different output therefore it will break referential +-- transparency. +-- +-- ====__Examples__ +-- +-- >>> :set -XTypeApplications +-- >>> fromListMemN @Char @(MBytes 'Inc) 3 "Hello" +-- (Left "lo",[0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00]) +-- >>> fromListMemN @Char @(MBytes 'Inc) 2 "Hi" +-- (Left "",[0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00]) +-- >>> fst $ fromListMemN @Char @(MBytes 'Inc) 5 "Hi" +-- Right (Count {unCount = 2}) +-- +-- @since 0.2.0 +fromListMemN :: + forall e ma. (Prim e, MemAlloc ma) + => Count e + -- ^ /memCount/ - Expected number of elements in the list, which exactly how much + -- memory will be allocated. + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- > unCount memCount <= length list + -> [e] + -- ^ /list/ - A list of elements to load into the newly allocated memory region. + -> (Either [e] (Count e), FrozenMem ma) +fromListMemN count xs = + createMemST count $ \mm -> do + (ys, loadedCount) <- loadListOffMutMemN count xs mm 0 + pure $ + if loadedCount /= count && null ys + then Right loadedCount + else Left ys +{-# INLINE fromListMemN #-} + + +-- | Just like `fromListMemN`, except it ensures safety by filling tail with zeros, +-- whenever the list is not long enough. +-- +-- ====__Examples__ +-- +-- >>> import Data.Prim.Memory +-- >>> :set -XTypeApplications +-- >>> fromListZeroMemN @Char @(MBytes 'Inc) 3 "Hi" +-- (Right (Count {unCount = 2}),[0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00,0x00,0x00,0x00,0x00]) +-- +-- @since 0.2.0 +fromListZeroMemN :: + forall e ma. (Prim e, MemAlloc ma) + => Count e -- ^ /memCount/ - Number of elements to load from the list. + -> [e] + -> (Either [e] (Count e), FrozenMem ma) +fromListZeroMemN count xs = + createMemST (max 0 count) $ \mm -> do + (ys, loadedCount) <- loadListOffMutMemN count xs mm 0 + let loadedByteCount = toByteCount loadedCount + surplusByteCount = toByteCount count - loadedByteCount + when (surplusByteCount > 0) $ setMutMem mm (countToOff loadedByteCount) surplusByteCount 0 + pure $ + if loadedCount /= count && null ys + then Right loadedCount + else Left ys +{-# INLINE fromListZeroMemN #-} + +-- | Same as `fromListZeroMemN`, but ignore the extra information about how the loading went. +-- +-- ====__Examples__ +-- +-- >>> import Data.Prim.Memory +-- >>> fromListZeroMemN_ 3 "Hi" :: Bytes 'Inc +-- [0x48,0x00,0x00,0x00,0x69,0x00,0x00,0x00,0x00,0x00,0x00,0x00] +-- +-- @since 0.2.0 +fromListZeroMemN_ :: + forall e ma. (Prim e, MemAlloc ma) + => Count e + -> [e] + -> FrozenMem ma +fromListZeroMemN_ !n = snd . fromListZeroMemN n +{-# INLINE fromListZeroMemN_ #-} + + + +-- Mutable loading -- + + +loadListByteOffHelper :: + (MemWrite mw, MonadPrim s m, Prim e) + => [e] + -> mw s + -> Off Word8 -- ^ Offset + -> Off Word8 -- ^ Upper bound + -> Off Word8 -- ^ Element size + -> m ([e], Count e) +loadListByteOffHelper ys mw byteOff k step = + let go [] i = pure ([], toLoadedCount i) + go a@(x:xs) i + | i < k = writeByteOffMutMem mw i x >> go xs (i + step) + | otherwise = pure (a, toLoadedCount i) + toLoadedCount i = fromByteCount (offToCount (i - byteOff)) + in go ys byteOff +{-# INLINE loadListByteOffHelper #-} + + +-- | Load elements from the supplied list into a mutable memory region. Loading will +-- start at the supplied offset in number of bytes and will stop when either supplied +-- @elemCount@ number is reached or there are no more elements left in the list to +-- load. This action returns a list of elements that did not get loaded and the count of +-- how many elements did get loaded. +-- +-- [Unsafe] When any precondition for either the offset @memTargetOff@ or the element +-- count @memCount@ is violated then a call to this function can result in heap corruption +-- or failure with a segfault. +-- +-- ====__Examples__ +-- +-- For example load the @"Hell"@ somewhere in the middle of `MBytes`: +-- +-- >>> ma <- allocZeroMutMem (6 :: Count Char) :: IO (MBytes 'Inc RW) +-- >>> loadListByteOffMutMemN 4 "Hello!" ma (toByteOff (1 :: Off Char)) +-- ("o!",Count {unCount = 4}) +-- >>> freezeMutMem ma +-- [0x00,0x00,0x00,0x00,0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x00,0x00,0x00,0x00] +-- +-- Or something more useful like loading prefixes from nested lists: +-- +-- >>> import Control.Monad +-- >>> foldM_ (\o xs -> (+ o) . countToByteOff . snd <$> loadListByteOffMutMemN 4 xs ma o) 2 [[x..] | x <- [1..5] :: [Word8]] +-- >>> freezeMutMem ma +-- [0x00,0x00,0x01,0x02,0x03,0x04,0x02,0x03,0x04,0x05,0x03,0x04,0x05,0x06,0x04,0x05,0x06,0x07,0x05,0x06,0x07,0x08,0x00,0x00] +-- +-- @since 0.2.0 +loadListByteOffMutMemN :: + (MemWrite mw, MonadPrim s m, Prim e) + => Count e + -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Target memory region must have enough memory to perform loading of @elemCount@ + -- elements starting at the @memTargetOff@ offset. For types that also implement + -- `MemAlloc` this can be described as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff + unCountBytes elemCount <= unCount (targetByteCount - byteCountType @e) + -> [e] -- ^ /listSource/ - List with elements that should be loaded + -> mw s -- ^ /memTarget/ - Memory region where to load the elements into + -> Off Word8 + -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory + -- region @memTarget@. For types that also implement `MemAlloc` this can be described + -- as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListByteOffMutMemN count ys mw byteOff = loadListByteOffHelper ys mw byteOff k step + where + k = byteOff + countToOff (toByteCount count) + step = countToOff $ byteCountProxy ys +{-# INLINABLE loadListByteOffMutMemN #-} + +-- | Same as `loadListByteOffMutMemN`, but infer the count from number of bytes that is +-- available in the target memory region. +-- +-- [Unsafe] When a precondition for the element count @memCount@ is violated then a call +-- to this function can result in heap corruption or failure with a segfault. +-- +-- ====__Examples__ +-- +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> ma <- allocZeroMutMem (5 :: Count Char) :: IO (MBytes 'Inc RW) +-- >>> freezeMutMem ma +-- [0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00] +-- >>> loadListByteOffMutMem "Hello World" ma 0 +-- (" World",Count {unCount = 5}) +-- >>> freezeMutMem ma +-- [0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] +-- >>> loadListByteOffMutMem ([0xff,0xff,0xff] :: [Word8]) ma 1 +-- ([],Count {unCount = 3}) +-- >>> freezeMutMem ma +-- [0x48,0xff,0xff,0xff,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] +-- +-- @since 0.3.0 +loadListByteOffMutMem :: + (MemAlloc ma, MonadPrim s m, Prim e) + => [e] -- ^ /listSource/ - List with elements that should be loaded + -> ma s -- ^ /memTarget/ - Memory region where to load the elements into + -> Off Word8 + -- ^ /memTargetOff/ - Offset in number of bytes into target memory where writing will start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory + -- region @memTarget@. For types that also implement `MemAlloc` this can be described + -- as: + -- + -- > targetByteCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff <= unCount (targetByteCount - byteCountType @e) + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListByteOffMutMem ys ma byteOff = do + bCount <- getByteCountMutMem ma + let k = countToOff bCount - byteOff + step = countToOff $ byteCountProxy ys + loadListByteOffHelper ys ma byteOff k step +{-# INLINABLE loadListByteOffMutMem #-} + +-- | Same as `loadListByteOffMutMemN`, but works with offset in number of elements instead of +-- bytes. +-- +-- [Unsafe] When preconditions for either the offset @memTargetOff@ or the element count +-- @memCount@ is violated then a call to this function can result in heap corruption or +-- failure with a segfault. +-- +-- @since 0.2.0 +loadListOffMutMemN :: + (MemWrite mw, MonadPrim s m, Prim e) + => Count e + -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Target memory region must have enough memory to perform loading of @elemCount@ + -- elements starting at the @memTargetOff@ offset. For types that also implement + -- `MemAlloc` this can be described as: + -- + -- > targetCount <- getCountMutMem memTarget + -- > unOff memTargetOff + unCount elemCount < unCount targetCount + -> [e] -- ^ /listSource/ - List with elements that should be loaded + -> mw s -- ^ /memTarget/ - Memory region where to load the elements into + -> Off e + -- ^ /memTargetOff/ - Offset in number of elements into target memory where writing will start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory + -- region @memTarget@. For types that also implement `MemAlloc` this can be described + -- as: + -- + -- > targetCount <- getByteCountMutMem memTarget + -- > unOff memTargetOff < unCount targetCount + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListOffMutMemN count ys mw off = + let go [] i = pure ([], toLoadedCount i) + go a@(x:xs) i + | i < k = writeOffMutMem mw i x >> go xs (i + 1) + | otherwise = pure (a, toLoadedCount i) + k = off + countToOff count + toLoadedCount i = offToCount (i - off) + in go ys off +{-# INLINABLE loadListOffMutMemN #-} + + +-- | Same as `loadListOffMutMemN`, but start loading at @0@ offset. +-- +-- [Unsafe] When any precondition for the element count @memCount@ is violated then a call to +-- this function can result in heap corruption or failure with a segfault. +-- +-- @since 0.2.0 +loadListMutMemN :: + forall e mw m s. (MemWrite mw, MonadPrim s m, Prim e) + => Count e + -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Target memory region must have enough memory to perform loading of @elemCount@ + -- elements. For types that also implement `MemAlloc` this can be described as: + -- + -- > targetCount <- getCountMutMem memTarget + -- > elemCount <= targetCount + -> [e] -- ^ /listSource/ - List with elements that should be loaded + -> mw s -- ^ /memTarget/ - Memory region where to load the elements into + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListMutMemN count xs mw = loadListOffMutMemN count xs mw 0 +{-# INLINABLE loadListMutMemN #-} + + + +-- | Same as `loadListMutMemN`, but ignores the result. +-- +-- [Unsafe] When any precondition for the element count @memCount@ is violated then a call +-- to this function can result in heap corruption or failure with a segfault. +-- +-- @since 0.2.0 +loadListMutMemN_ :: + forall e mw m s. (Prim e, MemWrite mw, MonadPrim s m) + => Count e + -- ^ /elemCount/ - Maximum number of elements to load from list into the memory region + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memCount + -- + -- Target memory region must have enough memory to perform loading of @elemCount@ + -- elements. For types that also implement `MemAlloc` this can be described as: + -- + -- > targetCount <- getCountMutMem memTarget + -- > elemCount <= targetCount + -> [e] -- ^ /listSource/ - List with elements that should be loaded + -> mw s -- ^ /memTarget/ - Memory region where to load the elements into + -> m () +loadListMutMemN_ (Count n) ys mb = + let go [] _ = pure () + go (x:xs) i = when (i < n) $ writeOffMutMem mb (Off i) x >> go xs (i + 1) + in go ys 0 +{-# INLINABLE loadListMutMemN_ #-} + + + + +-- | Same as `loadListOffMutMemN`, but infer the count from number of bytes that is available +-- in the target memory region. +-- +-- [Unsafe] When a precondition for the element count @memCount@ is violated then a call +-- to this function can result in heap corruption or failure with a segfault. +-- +-- @since 0.3.0 +loadListOffMutMem :: + forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) + => [e] -- ^ /listSource/ - List with elements that should be loaded + -> ma s -- ^ /memTarget/ - Memory region where to load the elements into + -> Off e + -- ^ /memTargetOff/ - Offset in number of elements into target memory where writing will + -- start + -- + -- /__Preconditions:__/ + -- + -- > 0 <= memTargetOff + -- + -- Once the pointer is advanced by @memTargetOff@ it must still refer to the same memory + -- region @memTarget@. For types that also implement `MemAlloc` this can be described + -- as: + -- + -- > targetCount <- getCountMutMem memTarget + -- > unOff memTargetOff < unCount targetCount + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListOffMutMem ys ma off = getCountMutMem ma >>= \c -> loadListOffMutMemN (c - offToCount off) ys ma off +{-# INLINE loadListOffMutMem #-} + + +-- | Same as `loadListMutMemN`, but tries to fit as many elements as possible into the mutable +-- memory region starting at the beginning. This operation is always safe. +-- +-- ====__Examples__ +-- +-- >>> import Data.Prim.Memory +-- >>> ma <- allocMutMem (5 :: Count Char) :: IO (MBytes 'Inc RW) +-- >>> loadListMutMem "HelloWorld" ma +-- ("World",Count {unCount = 5}) +-- >>> freezeMutMem ma +-- [0x48,0x00,0x00,0x00,0x65,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] +-- >>> loadListMutMem (replicate 6 (0xff :: Word8)) ma +-- ([],Count {unCount = 6}) +-- >>> freezeMutMem ma +-- [0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0x6c,0x00,0x00,0x00,0x6c,0x00,0x00,0x00,0x6f,0x00,0x00,0x00] +-- +-- @since 0.3.0 +loadListMutMem :: + forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) + => [e] -- ^ /listSource/ - List with elements to load + -> ma s -- ^ /memTarget/ - Mutable region where to load elements from the list + -> m ([e], Count e) + -- ^ Leftover part of the @listSource@ if any and the exact count of elements that have been loaded. +loadListMutMem ys ma = getCountMutMem ma >>= \c -> loadListOffMutMemN (c `countForProxyTypeOf` ys) ys ma 0 +{-# INLINE loadListMutMem #-} + +-- | Same as `loadListMutMem`, but ignores the result. Equivalence as property: +-- +-- prop> let c = fromInteger (abs i) :: Count Int in (createZeroMemST_ c (loadListMutMem_ (xs :: [Int])) :: Bytes 'Inc) == createZeroMemST_ c (void . loadListMutMem xs) +-- +-- @since 0.2.0 +loadListMutMem_ :: + forall e ma m s. (Prim e, MemAlloc ma, MonadPrim s m) + => [e] -- ^ /listSource/ - List with elements to load + -> ma s -- ^ /memTarget/ - Mutable region where to load elements from the list + -> m () +loadListMutMem_ ys mb = getCountMutMem mb >>= \c -> loadListMutMemN_ (c `countForProxyTypeOf` ys) ys mb +{-# INLINE loadListMutMem_ #-} + + +-- | Convert a memory region to a list of bytes. Equivalent to `Data.ByteString.unpack` +-- for `Data.ByteString.ByteString` +-- +-- ====__Example__ +-- +-- >>> toByteListMem (fromByteListMem [0..10] :: Bytes 'Pin) +-- [0,1,2,3,4,5,6,7,8,9,10] +-- +-- @since 0.1.0 +toByteListMem :: + forall ma. MemAlloc ma + => FrozenMem ma + -> [Word8] +toByteListMem = toListMem +{-# INLINE toByteListMem #-} + +-- mapMem :: +-- forall e e' mr ma. (MemRead mr, MemAlloc ma, Prim e, Prim e') +-- => (e -> e') +-- -> mr +-- -> (FrozenMem ma, [Word8]) +-- mapMem f = undefined + + +mapByteMem :: + forall e mr ma. (MemRead mr, MemAlloc ma, Prim e) + => (Word8 -> e) + -> mr + -> FrozenMem ma +mapByteMem f = imapByteOffMem (const f) + +-- Map an index aware function over memory region +-- +-- >>> import Data.Prim.Memory +-- >>> a = fromListMem [1 .. 10 :: Word8] :: Bytes 'Inc +-- >>> a +-- [0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] +-- >>> imapByteOffMem (\i e -> (fromIntegral i :: Int8, e + 0xf0)) a :: Bytes 'Pin +-- [0x00,0xf1,0x01,0xf2,0x02,0xf3,0x03,0xf4,0x04,0xf5,0x05,0xf6,0x06,0xf7,0x07,0xf8,0x08,0xf9,0x09,0xfa] +-- +-- @since 0.1.0 +imapByteOffMem :: + (MemRead mr, MemAlloc ma, Prim e) => (Off Word8 -> Word8 -> e) -> mr -> FrozenMem ma +imapByteOffMem f r = runST $ mapByteOffMemM (\i -> pure . f i) r + +-- @since 0.1.0 +mapByteMemM :: + (MemRead mr, MemAlloc ma, MonadPrim s m, Prim e) + => (Word8 -> m e) + -> mr + -> m (FrozenMem ma) +mapByteMemM f = mapByteOffMemM (const f) + + +-- @since 0.1.0 +mapByteOffMemM :: + forall e mr ma m s. (MemRead mr, MemAlloc ma, MonadPrim s m, Prim e) + => (Off Word8 -> Word8 -> m e) + -> mr + -> m (FrozenMem ma) +mapByteOffMemM f r = do + let bc@(Count n) = byteCountMem r + c = Count n `countForProxyTypeOf` f 0 0 + mem <- allocMutMem c + _ <- forByteOffMemM_ r 0 bc f + -- let go i = + -- when (i < n) $ do + -- f i (indexByteOffMem r (Off i)) >>= + -- writeOffMem mem (offAsProxy c (Off i)) + -- go (i + 1) + -- go 0 + freezeMutMem mem + + +-- | Iterate over a region of memory +forByteOffMemM_ :: + (MemRead mr, MonadPrim s m, Prim e) + => mr + -> Off Word8 + -> Count e + -> (Off Word8 -> e -> m b) + -> m (Off Word8) +forByteOffMemM_ r (Off byteOff) c f = + let n = coerce (toByteCount c) + byteOff + Count k = byteCountProxy c + go i + | i < n = f (Off i) (indexByteOffMem r (Off i)) >> go (i + k) + | otherwise = pure $ Off i + in go byteOff + +{- + +loopShort :: Int -> (Int -> a -> Bool) -> (Int -> Int) -> a -> (Int -> a -> a) -> a +loopShort !startAt condition increment !initAcc f = go startAt initAcc + where + go !step !acc = + if condition step acc + then go (increment step) (f step acc) + else acc +{-# INLINE loopShort #-} + +loopShortM :: Monad m => Int -> (Int -> a -> m Bool) -> (Int -> Int) -> a -> (Int -> a -> m a) -> m a +loopShortM !startAt condition increment !initAcc f = go startAt initAcc + where + go !step !acc = do + shouldContinue <- condition step acc + if shouldContinue + then f step acc >>= go (increment step) + else return acc +{-# INLINE loopShortM #-} + + + +ifoldlShortBytes :: + (Prim e) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> Bool) + -- ^ Continuation condition applied to an accumulator. When `False` it will terminate + -- early + -> (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> Bytes p + -- ^ Memory region to iterate over + -> a +ifoldlShortBytes off count g f initAcc mem = + loopShort (coerce off) cond (+ 1) initAcc inner + where + inner !i !acc = + let ioff = coerce i + in f acc ioff $! indexOffBytes mem ioff + {-# INLINE inner #-} + cond i a = g a && i < k + {-# INLINE cond #-} + k = coerce count +{-# INLINE ifoldlShortBytes #-} +-} + + + + + + + +{- + + + + +ifoldlShortMem :: + (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> Bool) + -- ^ Continuation condition applied to an accumulator. When `False` it will terminate + -- early + -> (a -> Off e -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +ifoldlShortMem off count g f initAcc mem = loop initAcc off + where + k = countToOff count + off + loop !acc !i + | g acc && i < k = loop (f acc i (indexOffMem mem i)) (i + 1) + | otherwise = acc + + -- loopShort (coerce off) (\i a -> g a && i < k) (+ 1) initAcc $ \ !i !acc -> + -- let ioff = coerce i + -- in f acc ioff (indexOffMem mem ioff) + -- where + -- k = coerce count +{-# INLINE ifoldlShortMem #-} + +ifoldlShortMemM :: + (Prim e, MemRead mr, Monad m) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> m Bool) + -- ^ Continuation condition applied to an accumulator. When `False` it will terminate + -- early + -> (a -> Off e -> e -> m a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> m a +ifoldlShortMemM off count g f initAcc mem = + loopShortM (coerce off) (\i a -> (\p -> p && i < k) <$> g a) (+ 1) initAcc $ \ !i !acc -> + let ioff = coerce i + in f acc ioff (indexOffMem mem ioff) + where + k = coerce count +{-# INLINE ifoldlShortMemM #-} + + +foldlShortMem :: + (Prim e, MemRead mr) + => Off e + -- ^ Initial offset to start at + -> Count e + -- ^ Total number of elements to iterate through + -> (a -> Bool) + -- ^ Continuation condition applied to an accumulator. When `False` it will terminate + -- early + -> (a -> e -> a) + -- ^ Folding function + -> a + -- ^ Initial accumulator + -> mr + -- ^ Memory region to iterate over + -> a +foldlShortMem off count g f = ifoldlShortMem off count g (\a _ -> f a) +{-# INLINE foldlShortMem #-} +-} + + + + +-- -- | Iterate over a region of memory +-- loopMemM_ :: +-- (MemRead mr, MonadPrim s m, Prim e) +-- => r +-- -> Off Word8 +-- -> Count e +-- -> (Count Word8 -> a -> Bool) +-- -> (Off Word8 -> e -> m b) +-- -> m (Off Word8) +-- foldlByteOffMemM_ r (Off byteOff) c f = +-- loopShortM byteOff (\i -> f (coerce i)) +-- let n = coerce (toByteCount c) + byteOff +-- Count k = byteCountProxy c +-- go i +-- | i < n = f (Off i) (indexByteOffMem r (Off i)) >> go (i + k) +-- | otherwise = pure $ Off i +-- in go byteOff + + +data MemView a = MemView + { mvOffset :: {-# UNPACK #-} !(Off Word8) + , mvCount :: {-# UNPACK #-} !(Count Word8) + , mvMem :: !a + } + +data MMemView a s = MMemView + { mmvOffset :: {-# UNPACK #-} !(Off Word8) + , mmvCount :: {-# UNPACK #-} !(Count Word8) + , mmvMem :: !(a s) + } + +izipWithByteOffMemM_ :: + (MemRead mr1, MemRead mr2, MonadPrim s m, Prim e) + => mr1 + -> Off Word8 + -> mr2 + -> Off Word8 + -> Count e + -> (Off Word8 -> e -> Off Word8 -> e -> m b) + -> m (Off Word8) +izipWithByteOffMemM_ r1 (Off byteOff1) r2 off2 c f = + let n = coerce (toByteCount c) + byteOff1 + Count k = byteCountProxy c + go i + | i < n = + let o1 = Off i + o2 = Off i + off2 + in f o1 (indexByteOffMem r1 o1) o2 (indexByteOffMem r2 o2) >> + go (i + k) + | otherwise = pure $ Off i + in go byteOff1 + + +izipWithOffMemM_ :: + (MemRead mr1, MemRead mr2, MonadPrim s m, Prim e1, Prim e2) + => mr1 + -> Off e1 + -> mr2 + -> Off e2 + -> Int + -> (Off e1 -> e1 -> Off e2 -> e2 -> m b) + -> m () +izipWithOffMemM_ r1 off1 r2 off2 nc f = + let n = nc + coerce off1 + go o1@(Off i) o2 = + when (i < n) $ + f o1 (indexOffMem r1 o1) o2 (indexOffMem r2 o2) >> go (o1 + 1) (o2 + 1) + in go off1 off2 + + +-- class Mut f => MFunctor f where +-- mmap :: (Elt f a, Elt f b, MonadPrim s m) => (a -> b) -> f a s -> m (f b s) + +-- class Mut f => MTraverse f where +-- mmapM :: (Elt f a, Elt f b, MonadPrim s m) => (a -> m b) -> f a s -> m (f b s) + +-- class MFunctor f => MApplicative f where +-- pureMut :: (Elt f a, MonadPrim s m) => a -> m (f a s) +-- liftMut :: +-- (Elt f a, Elt f b, Elt f c, MonadPrim s m) => (a -> b -> m c) -> f a s -> f b s -> m (f c s) + +-- class MApplicative f => MMonad f where +-- bindMut :: +-- (Elt f a, Elt f b, MonadPrim s m) => f a s -> (a -> m b) -> m (f b s) + +-- instance MFunctor MAddr where +-- mmap f maddr = do +-- Count n <- getCountMAddr maddr +-- maddr' <- allocMAddr (Count n) +-- let go i = +-- when (i < n) $ do +-- writeOffMAddr maddr' (Off i) . f =<< readOffMAddr maddr (Off i) +-- go (i + 1) +-- maddr' <$ go 0 + +-- instance MTraverse MAddr where +-- mmapM f maddr = do +-- Count n <- getCountMAddr maddr +-- maddr' <- allocMAddr (Count n) +-- let go i = +-- when (i < n) $ do +-- writeOffMAddr maddr' (Off i) =<< f =<< readOffMAddr maddr (Off i) +-- go (i + 1) +-- maddr' <$ go 0 + + +--------------------- +-- Bytes instances -- +--------------------- + +instance MemRead (Bytes p) where + isSameMem = isSameBytes + {-# INLINE isSameMem #-} + byteCountMem = byteCountBytes + {-# INLINE byteCountMem #-} + indexOffMem = indexOffBytes + {-# INLINE indexOffMem #-} + indexByteOffMem = indexByteOffBytes + {-# INLINE indexByteOffMem #-} + copyByteOffToMBytesMem = copyByteOffBytesToMBytes + {-# INLINE copyByteOffToMBytesMem #-} + copyByteOffToPtrMem = copyByteOffBytesToPtr + {-# INLINE copyByteOffToPtrMem #-} + compareByteOffToPtrMem bytes1 off1 ptr2 off2 c = + pure $! compareByteOffBytesToPtr bytes1 off1 ptr2 off2 c + {-# INLINE compareByteOffToPtrMem #-} + compareByteOffToBytesMem bytes1 off1 bytes2 off2 c = + compareByteOffBytes bytes1 off1 bytes2 off2 c + {-# INLINE compareByteOffToBytesMem #-} + compareByteOffMem mem1 off1 bs off2 c = + compareByteOffToBytesMem mem1 off1 bs off2 c + {-# INLINE compareByteOffMem #-} + +instance Typeable p => MemAlloc (MBytes p) where + type FrozenMem (MBytes p) = Bytes p + getByteCountMutMem = getByteCountMBytes + {-# INLINE getByteCountMutMem #-} + allocMutMem = allocMBytes + {-# INLINE allocMutMem #-} + thawMem = thawBytes + {-# INLINE thawMem #-} + freezeMutMem = freezeMBytes + {-# INLINE freezeMutMem #-} + reallocMutMem = reallocMBytes + {-# INLINE reallocMutMem #-} + +instance MemWrite (MBytes p) where + isSameMutMem = isSameMBytes + {-# INLINE isSameMutMem #-} + readOffMutMem = readOffMBytes + {-# INLINE readOffMutMem #-} + readByteOffMutMem = readByteOffMBytes + {-# INLINE readByteOffMutMem #-} + writeOffMutMem = writeOffMBytes + {-# INLINE writeOffMutMem #-} + writeByteOffMutMem = writeByteOffMBytes + {-# INLINE writeByteOffMutMem #-} + moveByteOffToPtrMutMem = moveByteOffMBytesToPtr + {-# INLINE moveByteOffToPtrMutMem #-} + moveByteOffToMBytesMutMem = moveByteOffMBytesToMBytes + {-# INLINE moveByteOffToMBytesMutMem #-} + moveByteOffMutMem = moveByteOffToMBytesMutMem + {-# INLINE moveByteOffMutMem #-} + copyByteOffMem = copyByteOffToMBytesMem + {-# INLINE copyByteOffMem #-} + setMutMem = setMBytes + {-# INLINE setMutMem #-} + + +instance Show (Bytes p) where + show b = + Foldable.foldr' ($) "]" $ + ('[' :) : List.intersperse (',' :) (map (("0x" ++) .) (showsHexMem b)) + +instance Typeable p => IsList (Bytes p) where + type Item (Bytes p) = Word8 + fromList = fromListMem + {-# INLINE fromList #-} + fromListN n = fromListZeroMemN_ (Count n) + {-# INLINE fromListN #-} + toList = toListMem + {-# INLINE toList #-} + +instance Eq (Bytes p) where + b1 == b2 = isSameBytes b1 b2 || eqByteMem b1 b2 + {-# INLINE (==) #-} + +instance Ord (Bytes p) where + compare b1 b2 = + compare n (byteCountBytes b2) <> compareByteOffBytes b1 0 b2 0 n + where + n = byteCountBytes b1 + {-# INLINE compare #-} + +instance Typeable p => Semigroup.Semigroup (Bytes p) where + (<>) = appendMem + {-# INLINE (<>) #-} + sconcat (x :| xs) = concatMem (x:xs) + {-# INLINE sconcat #-} + stimes i = cycleMemN (fromIntegral i) + {-# INLINE stimes #-} + +instance Typeable p => Monoid.Monoid (Bytes p) where + mappend = appendMem + {-# INLINE mappend #-} + mconcat = concatMem + {-# INLINE mconcat #-} + mempty = emptyMem + {-# INLINE mempty #-} + + +-- | A list of `ShowS` which covert bytes to base16 encoded strings. Each element of the list +-- is a function that will convert one byte. +-- +-- ====__Example__ +-- +-- >>> :set -XDataKinds +-- >>> import Data.Prim.Memory +-- >>> concatMap ($ " ") $ showsHexMem (fromListMem [1 :: Int16 .. 15] :: Bytes 'Inc) +-- "01 00 02 00 03 00 04 00 05 00 06 00 07 00 08 00 09 00 0a 00 0b 00 0c 00 0d 00 0e 00 0f 00 " +-- +-- @since 0.1.0 +showsHexMem :: MemRead mr => mr -> [ShowS] +showsHexMem b = map toHex (toListMem b :: [Word8]) + where + toHex b8 = + (if b8 <= 0x0f + then ('0' :) + else id) . + showHex b8 + +-- | Allocate a new region of memory and Ensure that it is filled with zeros before and +-- after it gets used. `PtrAccess` is not used directly, but instead is used to guarantee +-- that the memory is pinned and its contents will not get moved around by the garbage +-- collector. +-- +-- @since 0.3.0 +withScrubbedMutMem :: + forall e ma m a. + (MonadUnliftPrim RW m, Prim e, MemAlloc ma, PtrAccess RW (ma RW)) + => Count e + -> (ma RW -> m a) + -> m a +withScrubbedMutMem c f = do + mem <- allocZeroMutMem c + let _fptr = toForeignPtr mem :: IO (ForeignPtr e) -- Enforce the `PtrAccess` constraint. + f mem `ufinally` setMutMem mem 0 (toByteCount c) 0 +{-# INLINE withScrubbedMutMem #-} diff --git a/src/Data/Prim/Memory/PArray.hs b/src/Data/Prim/Memory/PArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/PArray.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Prim.Memory.PArray +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Memory.PArray + ( PArray(..) + , PMArray(..) + , Pinned(..) + , fromBytesPArray + , toBytesPArray + , fromUArrayPArray + , toUArrayPArray + , castPArray + , fromMBytesPMArray + , toMBytesPMArray + , fromUMArrayPMArray + , toUMArrayPMArray + , castPMArray + , allocPMArray + , allocPinnedPMArray + , allocAlignedPMArray + , allocUnpinnedPMArray + , shrinkPMArray + , resizePMArray + , reallocPMArray + , isPinnedPArray + , isPinnedPMArray + + , thawPArray + , freezePMArray + , sizePArray + , getSizePMArray + , readPMArray + , writePMArray + + , setPMArray + , copyPArrayToPMArray + , movePMArrayToPMArray + ) where + +import Control.DeepSeq +import Control.Prim.Monad +import Data.Prim +import Data.Prim.Array (Size(..), UArray(..), UMArray(..)) +import Data.Prim.Memory.Bytes +import Data.Prim.Memory.Fold +import Data.Prim.Memory.ForeignPtr +import Data.Prim.Memory.Internal +import Foreign.Prim + +-- | An immutable array with elements of type @e@ +newtype PArray (p :: Pinned) e = PArray (Bytes p) + deriving (NFData, Semigroup, Monoid, MemRead) +type role PArray nominal nominal + + +instance (Prim e, Eq e) => Eq (PArray p e) where + (==) = eqMem @e + {-# INLINE (==) #-} + +instance (Prim e, Ord e) => Ord (PArray p e) where + compare = compareMem @e + {-# INLINE compare #-} + +-- | A mutable array with elements of type @e@ +newtype PMArray (p :: Pinned) e s = PMArray (MBytes p s) + deriving (NFData, MemWrite) +type role PMArray nominal nominal nominal + +-- | Read-only access, but it is not enforced. +instance PtrAccess s (PArray 'Pin e) where + toForeignPtr = pure . toForeignPtrBytes . toBytesPArray + {-# INLINE toForeignPtr #-} + withPtrAccess b = withPtrBytes (toBytesPArray b) + {-# INLINE withPtrAccess #-} + withNoHaltPtrAccess b = withNoHaltPtrBytes (toBytesPArray b) + {-# INLINE withNoHaltPtrAccess #-} + +instance PtrAccess s (PMArray 'Pin e s) where + toForeignPtr = pure . toForeignPtrMBytes . toMBytesPMArray + {-# INLINE toForeignPtr #-} + withPtrAccess mb = withPtrMBytes (toMBytesPMArray mb) + {-# INLINE withPtrAccess #-} + withNoHaltPtrAccess mb = withNoHaltPtrMBytes (toMBytesPMArray mb) + {-# INLINE withNoHaltPtrAccess #-} + +instance Typeable p => MemAlloc (PMArray p e) where + type FrozenMem (PMArray p e) = PArray p e + getByteCountMutMem = getByteCountMutMem . toMBytesPMArray + {-# INLINE getByteCountMutMem #-} + allocMutMem = fmap fromMBytesPMArray . allocMBytes + {-# INLINE allocMutMem #-} + thawMem = thawPArray + {-# INLINE thawMem #-} + freezeMutMem = freezePMArray + {-# INLINE freezeMutMem #-} + reallocMutMem mba = fmap fromMBytesPMArray . reallocMBytes (toMBytesPMArray mba) + {-# INLINE reallocMutMem #-} + +instance (Typeable p, Prim e) => IsList (PArray p e) where + type Item (PArray p e) = e + fromList = fromListMem + fromListN n = fromListZeroMemN_ (Count n) + toList = toListMem + +instance Typeable p => IsString (PArray p Char) where + fromString = fromListMem + +instance (Show e, Prim e) => Show (PArray p e) where + show = show . toListPArray + + +toListPArray :: Prim e => PArray p e -> [e] +toListPArray = toListMem + +castPArray :: PArray p e' -> PArray p e +castPArray = coerce + +-- | /O(1)/ - Cast `PArray` to `UArray` +-- +-- @since 0.3.0 +toUArrayPArray :: PArray p e -> UArray e +toUArrayPArray pa = UArray (toByteArray# (toBytesPArray pa)) +{-# INLINE toUArrayPArray #-} + +-- | /O(1)/ - Cast `UArray` to `PArray` +-- +-- @since 0.3.0 +fromUArrayPArray :: UArray e -> PArray 'Inc e +fromUArrayPArray (UArray ba#) = fromBytesPArray (fromByteArray# ba#) +{-# INLINE fromUArrayPArray #-} + +fromBytesPArray :: Bytes p -> PArray p e +fromBytesPArray = coerce + +toBytesPArray :: PArray p e -> Bytes p +toBytesPArray = coerce + +castPMArray :: PMArray p e' s -> PMArray p e s +castPMArray = coerce + +fromMBytesPMArray :: MBytes p s -> PMArray p e s +fromMBytesPMArray = coerce + +toMBytesPMArray :: PMArray p e s -> MBytes p s +toMBytesPMArray = coerce + +-- | /O(1)/ - Cast `PMArray` to `UMArray` +-- +-- @since 0.3.0 +toUMArrayPMArray :: PMArray p e s -> UMArray e s +toUMArrayPMArray pa = UMArray (toMutableByteArray# (toMBytesPMArray pa)) +{-# INLINE toUMArrayPMArray #-} + +-- | /O(1)/ - Cast `UMArray` to `PMArray` +-- +-- @since 0.3.0 +fromUMArrayPMArray :: UMArray e s -> PMArray 'Inc e s +fromUMArrayPMArray (UMArray mba#) = fromMBytesPMArray (fromMutableByteArray# mba#) +{-# INLINE fromUMArrayPMArray #-} + + +sizePArray :: forall e p. Prim e => PArray p e -> Size +sizePArray = (coerce :: Count e -> Size) . countBytes . toBytesPArray +{-# INLINE sizePArray #-} + +getSizePMArray :: forall e p m s. (MonadPrim s m, Prim e) => PMArray p e s -> m Size +getSizePMArray = fmap (coerce :: Count e -> Size) . getCountMBytes . toMBytesPMArray +{-# INLINE getSizePMArray #-} + +allocPMArray :: + forall e p m s . (Typeable p, Prim e, MonadPrim s m) => Size -> m (PMArray p e s) +allocPMArray sz = fromMBytesPMArray <$> allocMBytes (coerce sz :: Count e) +{-# INLINE allocPMArray #-} + +allocUnpinnedPMArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (PMArray 'Inc e s) +allocUnpinnedPMArray sz = fromMBytesPMArray <$> allocUnpinnedMBytes (coerce sz :: Count e) +{-# INLINE allocUnpinnedPMArray #-} + +allocPinnedPMArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (PMArray 'Pin e s) +allocPinnedPMArray sz = fromMBytesPMArray <$> allocPinnedMBytes (coerce sz :: Count e) +{-# INLINE allocPinnedPMArray #-} + +allocAlignedPMArray :: + (MonadPrim s m, Prim e) + => Count e -- ^ Size in number of bytes + -> m (PMArray 'Pin e s) +allocAlignedPMArray = fmap fromMBytesPMArray . allocAlignedMBytes +{-# INLINE allocAlignedPMArray #-} + +freezePMArray :: MonadPrim s m => PMArray p e s -> m (PArray p e) +freezePMArray = fmap fromBytesPArray . freezeMBytes . toMBytesPMArray +{-# INLINE freezePMArray #-} + +thawPArray :: MonadPrim s m => PArray p e -> m (PMArray p e s) +thawPArray = fmap fromMBytesPMArray . thawBytes . toBytesPArray +{-# INLINE thawPArray #-} + +-- | Shrink mutable bytes to new specified count of elements. The new count must be less +-- than or equal to the current count as reported by `getCountPMArray`. +shrinkPMArray :: + forall e p m s. (MonadPrim s m, Prim e) + => PMArray p e s + -> Size + -> m () +shrinkPMArray mba sz = shrinkMBytes (toMBytesPMArray mba) (coerce sz :: Count e) +{-# INLINE shrinkPMArray #-} + + +-- | Attempt to resize mutable bytes in place. +-- +-- * New bytes might be allocated, with the copy of an old one. +-- * Old references should not be kept around to allow GC to claim it +-- * Old references should not be used to avoid undefined behavior +resizePMArray :: + forall e p m s. (MonadPrim s m, Prim e) + => PMArray p e s + -> Size + -> m (PMArray 'Inc e s) +resizePMArray mba sz = + fromMBytesPMArray <$> + resizeMBytes (toMBytesPMArray mba) (coerce sz :: Count e) +{-# INLINE resizePMArray #-} + +reallocPMArray :: + forall e p m s. (MonadPrim s m, Typeable p, Prim e) + => PMArray p e s + -> Size + -> m (PMArray p e s) +reallocPMArray mba sz = + fromMBytesPMArray <$> + reallocMBytes (toMBytesPMArray mba) (coerce sz :: Count e) +{-# INLINABLE reallocPMArray #-} + + +isPinnedPArray :: PArray p e -> Bool +isPinnedPArray (PArray b) = isPinnedBytes b +{-# INLINE isPinnedPArray #-} + +isPinnedPMArray :: PMArray p e s -> Bool +isPinnedPMArray (PMArray mb) = isPinnedMBytes mb +{-# INLINE isPinnedPMArray #-} + +readPMArray :: (MonadPrim s m, Prim e) => PMArray p e s -> Int -> m e +readPMArray (PMArray mb) = readOffMBytes mb . coerce +{-# INLINE readPMArray #-} + +writePMArray :: (MonadPrim s m, Prim e) => PMArray p e s -> Int -> e -> m () +writePMArray (PMArray mb) o = writeOffMBytes mb (coerce o) +{-# INLINE writePMArray #-} + + + +setPMArray :: + forall e p m s. (MonadPrim s m, Prim e) + => PMArray p e s -- ^ Chunk of memory to fill + -> Int -- ^ Offset in number of elements + -> Size -- ^ Number of cells to fill + -> e -- ^ A value to fill the cells with + -> m () +setPMArray (PMArray mb) off sz = setMBytes mb (coerce off) (coerce sz) +{-# INLINE setPMArray #-} + +copyPArrayToPMArray :: + forall e p m s. (MonadPrim s m, Prim e) + => PArray p e + -> Int + -> PMArray p e s + -> Int + -> Size + -> m () +copyPArrayToPMArray ba srcOff mba dstOff sz = + copyMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz `countForProxyTypeOf` ba) +{-# INLINE copyPArrayToPMArray #-} + +movePMArrayToPMArray :: + forall e p m s. (MonadPrim s m, Prim e) + => PMArray p e s + -> Int + -> PMArray p e s + -> Int + -> Size + -> m () +movePMArrayToPMArray ba srcOff mba dstOff sz = + moveMutMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz :: Count e) +{-# INLINE movePMArrayToPMArray #-} + + + +-- toPtrPArray :: PArray Pin e -> Ptr e +-- toPtrPArray (PArray ba#) = Ptr (byteArrayContents# ba#) +-- {-# INLINE toPtrPArray #-} + +-- toPtrPMArray :: PMArray Pin e s -> Ptr e +-- toPtrPMArray (PMArray mba#) = Ptr (mutablePArrayContents# mba#) +-- {-# INLINE toPtrPMArray #-} + +-- -- | Pointer access to immutable `PArray` should be for read only purposes, but it is +-- -- not enforced. Any mutation will break referential transparency +-- withPtrPArray :: MonadPrim s m => PArray Pin e -> (Ptr e -> m b) -> m b +-- withPtrPArray b f = do +-- res <- f (toPtrPArray b) +-- res <$ touch b +-- {-# INLINE withPtrPArray #-} + +-- -- | Same as `withPtrPArray`, but is suitable for actions that don't terminate +-- withNoHaltPtrPArray :: MonadUnliftPrim s m => PArray Pin e -> (Ptr e -> m b) -> m b +-- withNoHaltPtrPArray b f = withAliveUnliftPrim b $ f (toPtrPArray b) +-- {-# INLINE withNoHaltPtrPArray #-} + +-- withPtrPMArray :: MonadPrim s m => PMArray Pin e s -> (Ptr e -> m b) -> m b +-- withPtrPMArray mb f = do +-- res <- f (toPtrPMArray mb) +-- res <$ touch mb +-- {-# INLINE withPtrPMArray #-} + +-- withNoHaltPtrPMArray :: MonadUnliftPrim s m => PMArray Pin e s -> (Ptr e -> m b) -> m b +-- withNoHaltPtrPMArray mb f = withAliveUnliftPrim mb $ f (toPtrPMArray mb) +-- {-# INLINE withNoHaltPtrPMArray #-} + + +-- -- -- | Check if two byte arrays refer to pinned memory and compare their pointers. +-- -- isSamePArray :: PArray p1 e -> PArray p2 e -> Bool +-- -- isSamePArray (PArray b1#) (PArray b2#) = isTrue# (isSameByteArray# b1# b2#) +-- -- {-# INLINE[0] isSamePArray #-} +-- -- {-# RULES +-- -- "isSamePinnedPArray" isSamePArray = isSamePinnedPArray +-- -- #-} + +-- -- -- | Perform pointer equality on pinned `PArray`. +-- -- isSamePinnedPArray :: PArray Pin e -> PArray Pin e -> Bool +-- -- isSamePinnedPArray pb e1 pb2 = toPtrPArray pb e1 == toPtrPArray pb e2 +-- -- {-# INLINE isSamePinnedPArray #-} + + + +-- -- byteStringConvertError :: String -> a +-- -- byteStringConvertError msg = error $ "Cannot convert 'ByteString'. " ++ msg +-- -- {-# NOINLINE byteStringConvertError #-} + diff --git a/src/Data/Prim/Memory/PrimArray.hs b/src/Data/Prim/Memory/PrimArray.hs deleted file mode 100644 --- a/src/Data/Prim/Memory/PrimArray.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Prim.Memory.PrimArray --- Copyright : (c) Alexey Kuleshevich 2020 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Prim.Memory.PrimArray - ( PrimArray(..) - , MPrimArray(..) - , Pinned(..) - , fromBytesPrimArray - , toBytesPrimArray - , castPrimArray - , fromMBytesMPrimArray - , toMBytesMPrimArray - , castMPrimArray - , allocMPrimArray - , allocPinnedMPrimArray - , allocAlignedMPrimArray - , allocUnpinnedMPrimArray - , shrinkMPrimArray - , resizeMPrimArray - , reallocMPrimArray - , isPinnedPrimArray - , isPinnedMPrimArray - - , thawPrimArray - , freezeMPrimArray - , sizePrimArray - , getSizeMPrimArray - , readMPrimArray - , writeMPrimArray - - , setMPrimArray - , copyPrimArrayToMPrimArray - , moveMPrimArrayToMPrimArray - ) where - -import Control.DeepSeq -import Control.Prim.Monad -import Foreign.Prim -import Data.Prim -import Data.Prim.Memory.Bytes -import Data.Prim.Memory.Internal -import Data.Prim.Memory.ForeignPtr - - --- | An immutable array of bytes of type @e@ -newtype PrimArray (p :: Pinned) e = PrimArray (Bytes p) - deriving (NFData, Semigroup, Monoid, MemRead) -type role PrimArray nominal nominal - --- | A mutable array of bytes of type @e@ -newtype MPrimArray (p :: Pinned) e s = MPrimArray (MBytes p s) - deriving (NFData, MemWrite) -type role MPrimArray nominal nominal nominal - --- | Read-only access, but it is not enforced. -instance PtrAccess s (PrimArray 'Pin e) where - toForeignPtr = pure . toForeignPtrBytes . toBytesPrimArray - {-# INLINE toForeignPtr #-} - withPtrAccess b = withPtrBytes (toBytesPrimArray b) - {-# INLINE withPtrAccess #-} - withNoHaltPtrAccess b = withNoHaltPtrBytes (toBytesPrimArray b) - {-# INLINE withNoHaltPtrAccess #-} - -instance PtrAccess s (MPrimArray 'Pin e s) where - toForeignPtr = pure . toForeignPtrMBytes . toMBytesMPrimArray - {-# INLINE toForeignPtr #-} - withPtrAccess mb = withPtrMBytes (toMBytesMPrimArray mb) - {-# INLINE withPtrAccess #-} - withNoHaltPtrAccess mb = withNoHaltPtrMBytes (toMBytesMPrimArray mb) - {-# INLINE withNoHaltPtrAccess #-} - -instance Typeable p => MemAlloc (MPrimArray p e) where - type FrozenMem (MPrimArray p e) = PrimArray p e - getByteCountMem = getByteCountMem . toMBytesMPrimArray - {-# INLINE getByteCountMem #-} - allocMem = fmap fromMBytesMPrimArray . allocMBytes - {-# INLINE allocMem #-} - thawMem = thawPrimArray - {-# INLINE thawMem #-} - freezeMem = freezeMPrimArray - {-# INLINE freezeMem #-} - resizeMem mba = fmap fromMBytesMPrimArray . reallocMBytes (toMBytesMPrimArray mba) - {-# INLINE resizeMem #-} - -instance (Typeable p, Prim e) => IsList (PrimArray p e) where - type Item (PrimArray p e) = e - fromList = fromListMem - fromListN n = fromListZeroMemN_ (Count n) - toList = toListMem - -instance Typeable p => IsString (PrimArray p Char) where - fromString = fromListMem - -instance (Show e, Prim e) => Show (PrimArray p e) where - show = show . toListPrimArray - - -toListPrimArray :: Prim e => PrimArray p e -> [e] -toListPrimArray = toListMem - -castPrimArray :: PrimArray p e' -> PrimArray p e -castPrimArray = coerce - -fromBytesPrimArray :: Bytes p -> PrimArray p e -fromBytesPrimArray = coerce - -toBytesPrimArray :: PrimArray p e -> Bytes p -toBytesPrimArray = coerce - -castMPrimArray :: MPrimArray p e' s -> MPrimArray p e s -castMPrimArray = coerce - -fromMBytesMPrimArray :: MBytes p s -> MPrimArray p e s -fromMBytesMPrimArray = coerce - -toMBytesMPrimArray :: MPrimArray p e s -> MBytes p s -toMBytesMPrimArray = coerce - -sizePrimArray :: forall e p. Prim e => PrimArray p e -> Size -sizePrimArray = (coerce :: Count e -> Size) . countBytes . toBytesPrimArray -{-# INLINE sizePrimArray #-} - -getSizeMPrimArray :: forall e p m s. (MonadPrim s m, Prim e) => MPrimArray p e s -> m Size -getSizeMPrimArray = fmap (coerce :: Count e -> Size) . getCountMBytes . toMBytesMPrimArray -{-# INLINE getSizeMPrimArray #-} - -allocMPrimArray :: - forall e p m s . (Typeable p, Prim e, MonadPrim s m) => Size -> m (MPrimArray p e s) -allocMPrimArray sz = fromMBytesMPrimArray <$> allocMBytes (coerce sz :: Count e) -{-# INLINE allocMPrimArray #-} - -allocUnpinnedMPrimArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MPrimArray 'Inc e s) -allocUnpinnedMPrimArray sz = fromMBytesMPrimArray <$> allocUnpinnedMBytes (coerce sz :: Count e) -{-# INLINE allocUnpinnedMPrimArray #-} - -allocPinnedMPrimArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MPrimArray 'Pin e s) -allocPinnedMPrimArray sz = fromMBytesMPrimArray <$> allocPinnedMBytes (coerce sz :: Count e) -{-# INLINE allocPinnedMPrimArray #-} - -allocAlignedMPrimArray :: - (MonadPrim s m, Prim e) - => Count e -- ^ Size in number of bytes - -> m (MPrimArray 'Pin e s) -allocAlignedMPrimArray = fmap fromMBytesMPrimArray . allocAlignedMBytes -{-# INLINE allocAlignedMPrimArray #-} - -freezeMPrimArray :: MonadPrim s m => MPrimArray p e s -> m (PrimArray p e) -freezeMPrimArray = fmap fromBytesPrimArray . freezeMBytes . toMBytesMPrimArray -{-# INLINE freezeMPrimArray #-} - -thawPrimArray :: MonadPrim s m => PrimArray p e -> m (MPrimArray p e s) -thawPrimArray = fmap fromMBytesMPrimArray . thawBytes . toBytesPrimArray -{-# INLINE thawPrimArray #-} - --- | Shrink mutable bytes to new specified count of elements. The new count must be less --- than or equal to the current count as reported by `getCountMPrimArray`. -shrinkMPrimArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MPrimArray p e s - -> Size - -> m () -shrinkMPrimArray mba sz = shrinkMBytes (toMBytesMPrimArray mba) (coerce sz :: Count e) -{-# INLINE shrinkMPrimArray #-} - - --- | Attempt to resize mutable bytes in place. --- --- * New bytes might be allocated, with the copy of an old one. --- * Old references should not be kept around to allow GC to claim it --- * Old references should not be used to avoid undefined behavior -resizeMPrimArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MPrimArray p e s - -> Size - -> m (MPrimArray 'Inc e s) -resizeMPrimArray mba sz = - fromMBytesMPrimArray <$> - resizeMBytes (toMBytesMPrimArray mba) (coerce sz :: Count e) -{-# INLINE resizeMPrimArray #-} - -reallocMPrimArray :: - forall e p m s. (MonadPrim s m, Typeable p, Prim e) - => MPrimArray p e s - -> Size - -> m (MPrimArray p e s) -reallocMPrimArray mba sz = - fromMBytesMPrimArray <$> - reallocMBytes (toMBytesMPrimArray mba) (coerce sz :: Count e) -{-# INLINABLE reallocMPrimArray #-} - - -isPinnedPrimArray :: PrimArray p e -> Bool -isPinnedPrimArray (PrimArray b) = isPinnedBytes b -{-# INLINE isPinnedPrimArray #-} - -isPinnedMPrimArray :: MPrimArray p e s -> Bool -isPinnedMPrimArray (MPrimArray mb) = isPinnedMBytes mb -{-# INLINE isPinnedMPrimArray #-} - -readMPrimArray :: (MonadPrim s m, Prim e) => MPrimArray p e s -> Int -> m e -readMPrimArray (MPrimArray mb) = readOffMBytes mb . coerce -{-# INLINE readMPrimArray #-} - -writeMPrimArray :: (MonadPrim s m, Prim e) => MPrimArray p e s -> Int -> e -> m () -writeMPrimArray (MPrimArray mb) o = writeOffMBytes mb (coerce o) -{-# INLINE writeMPrimArray #-} - - - -setMPrimArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MPrimArray p e s -- ^ Chunk of memory to fill - -> Int -- ^ Offset in number of elements - -> Size -- ^ Number of cells to fill - -> e -- ^ A value to fill the cells with - -> m () -setMPrimArray (MPrimArray mb) off sz = setMBytes mb (coerce off) (coerce sz) -{-# INLINE setMPrimArray #-} - -copyPrimArrayToMPrimArray :: - forall e p m s. (MonadPrim s m, Prim e) - => PrimArray p e - -> Int - -> MPrimArray p e s - -> Int - -> Size - -> m () -copyPrimArrayToMPrimArray ba srcOff mba dstOff sz = - copyMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz `countForProxyTypeOf` ba) -{-# INLINE copyPrimArrayToMPrimArray #-} - -moveMPrimArrayToMPrimArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MPrimArray p e s - -> Int - -> MPrimArray p e s - -> Int - -> Size - -> m () -moveMPrimArrayToMPrimArray ba srcOff mba dstOff sz = - moveMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz :: Count e) -{-# INLINE moveMPrimArrayToMPrimArray #-} - - - --- toPtrPrimArray :: PrimArray Pin e -> Ptr e --- toPtrPrimArray (PrimArray ba#) = Ptr (byteArrayContents# ba#) --- {-# INLINE toPtrPrimArray #-} - --- toPtrMPrimArray :: MPrimArray Pin e s -> Ptr e --- toPtrMPrimArray (MPrimArray mba#) = Ptr (mutablePrimArrayContents# mba#) --- {-# INLINE toPtrMPrimArray #-} - --- -- | Pointer access to immutable `PrimArray` should be for read only purposes, but it is --- -- not enforced. Any mutation will break referential transparency --- withPtrPrimArray :: MonadPrim s m => PrimArray Pin e -> (Ptr e -> m b) -> m b --- withPtrPrimArray b f = do --- res <- f (toPtrPrimArray b) --- res <$ touch b --- {-# INLINE withPtrPrimArray #-} - --- -- | Same as `withPtrPrimArray`, but is suitable for actions that don't terminate --- withNoHaltPtrPrimArray :: MonadUnliftPrim s m => PrimArray Pin e -> (Ptr e -> m b) -> m b --- withNoHaltPtrPrimArray b f = withAliveUnliftPrim b $ f (toPtrPrimArray b) --- {-# INLINE withNoHaltPtrPrimArray #-} - --- withPtrMPrimArray :: MonadPrim s m => MPrimArray Pin e s -> (Ptr e -> m b) -> m b --- withPtrMPrimArray mb f = do --- res <- f (toPtrMPrimArray mb) --- res <$ touch mb --- {-# INLINE withPtrMPrimArray #-} - --- withNoHaltPtrMPrimArray :: MonadUnliftPrim s m => MPrimArray Pin e s -> (Ptr e -> m b) -> m b --- withNoHaltPtrMPrimArray mb f = withAliveUnliftPrim mb $ f (toPtrMPrimArray mb) --- {-# INLINE withNoHaltPtrMPrimArray #-} - - --- -- -- | Check if two byte arrays refer to pinned memory and compare their pointers. --- -- isSamePrimArray :: PrimArray p1 e -> PrimArray p2 e -> Bool --- -- isSamePrimArray (PrimArray b1#) (PrimArray b2#) = isTrue# (isSameByteArray# b1# b2#) --- -- {-# INLINE[0] isSamePrimArray #-} --- -- {-# RULES --- -- "isSamePinnedPrimArray" isSamePrimArray = isSamePinnedPrimArray --- -- #-} - --- -- -- | Perform pointer equality on pinned `PrimArray`. --- -- isSamePinnedPrimArray :: PrimArray Pin e -> PrimArray Pin e -> Bool --- -- isSamePinnedPrimArray pb e1 pb2 = toPtrPrimArray pb e1 == toPtrPrimArray pb e2 --- -- {-# INLINE isSamePinnedPrimArray #-} - - - --- -- byteStringConvertError :: String -> a --- -- byteStringConvertError msg = error $ "Cannot convert 'ByteString'. " ++ msg --- -- {-# NOINLINE byteStringConvertError #-} - diff --git a/src/Data/Prim/Memory/Text.hs b/src/Data/Prim/Memory/Text.hs --- a/src/Data/Prim/Memory/Text.hs +++ b/src/Data/Prim/Memory/Text.hs @@ -14,10 +14,10 @@ , MText(..) , Array(..) , MArray(..) - , toBytesArray - , fromBytesArray - , toMBytesMArray - , fromMBytesMArray + , fromArrayBytes + , toArrayBytes + , fromMArrayMBytes + , toMArrayMBytes ) where import Data.Text.Array @@ -35,20 +35,32 @@ {-# UNPACK #-}!Int -- offset (units of Word16, not Char) {-# UNPACK #-}!Int -- length (units of Word16, not Char) -toBytesArray :: Array -> Bytes 'Inc -toBytesArray (Array ba#) = Bytes ba# -{-# INLINE toBytesArray #-} +-- | /O(1)/ - Cast an immutable `Data.Text.Array.Array` from @text@ package to immutable `Bytes` +-- +-- @since 0.3.0 +fromArrayBytes :: Array -> Bytes 'Inc +fromArrayBytes (Array ba#) = Bytes ba# +{-# INLINE fromArrayBytes #-} -fromBytesArray :: Bytes p -> Array -fromBytesArray (Bytes ba#) = Array ba# -{-# INLINE fromBytesArray #-} +-- | /O(1)/ - Cast immutable `Bytes` to an immutable `Data.Text.Array.Array` from @text@ package +-- +-- @since 0.3.0 +toArrayBytes :: Bytes p -> Array +toArrayBytes (Bytes ba#) = Array ba# +{-# INLINE toArrayBytes #-} -toMBytesMArray :: MArray s -> MBytes 'Inc s -toMBytesMArray (MArray mba#) = MBytes mba# -{-# INLINE toMBytesMArray #-} +-- | /O(1)/ - Cast a mutable `Data.Text.Array.MArray` from @text@ package to mutable `MBytes` +-- +-- @since 0.3.0 +fromMArrayMBytes :: MArray s -> MBytes 'Inc s +fromMArrayMBytes (MArray mba#) = MBytes mba# +{-# INLINE fromMArrayMBytes #-} -fromMBytesMArray :: MBytes p s -> MArray s -fromMBytesMArray (MBytes ba#) = MArray ba# -{-# INLINE fromMBytesMArray #-} +-- | /O(1)/ - Cast mutable `MBytes` to a mutable `Data.Text.Array.MArray` from @text@ package +-- +-- @since 0.3.0 +toMArrayMBytes :: MBytes p s -> MArray s +toMArrayMBytes (MBytes ba#) = MArray ba# +{-# INLINE toMArrayMBytes #-}