diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog for primal-memory -## 0.1.0.0 +## 0.2.0 + +* Rename `ByteArray` -> `PrimArray` +* Improve `fromList` conversion +* Get rid of `allocByteCountMem` in favor of more general `allocMem` + +## 0.1.0 * Initial release diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -24,11 +24,11 @@ mb1 <- allocAlignedMBytes n64 mb2 <- allocAlignedMBytes n64 b1 <- freezeMBytes mb1 - mba <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 8 + mba <- BA.newAlignedPinnedByteArray (unCountBytes (n :: Count Word64)) 8 ba <- BA.unsafeFreezeByteArray mba -- Ensure that arrays are equal by filling them with zeros - mbaEq1 <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 8 - mbaEq2 <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 8 + 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) defaultMain diff --git a/bench/Conversion.hs b/bench/Conversion.hs --- a/bench/Conversion.hs +++ b/bench/Conversion.hs @@ -13,7 +13,6 @@ import qualified Foreign.ForeignPtr as GHC import Foreign.Storable import Data.Prim.Memory.ForeignPtr -import Data.Semigroup import qualified Data.Primitive.ByteArray as BA main :: IO () @@ -26,13 +25,13 @@ mb2 <- allocAlignedMBytes n64 mb3 <- allocAlignedMBytes n64 let fp = toForeignPtrMBytes mb3 - mba <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 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 - mbaEq1 <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 8 - mbaEq2 <- BA.newAlignedPinnedByteArray (fromCount (n :: Count Word64)) 8 + 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 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.1.0.0 +version: 0.2.0.0 synopsis: Unified interface for memory managemenet. description: Please see the README on GitHub at homepage: https://github.com/lehins/primal @@ -25,33 +25,39 @@ library hs-source-dirs: src exposed-modules: Data.Prim.Memory - , Data.Prim.Memory.ByteArray - , Data.Prim.Memory.Bytes , Data.Prim.Memory.Addr , Data.Prim.Memory.ByteString + , Data.Prim.Memory.Bytes + , Data.Prim.Memory.ForeignPtr + , Data.Prim.Memory.PrimArray , Data.Prim.Memory.Ptr + , Data.Prim.Memory.Text , Data.Prim.Memory.Internal - , Data.Prim.Memory.ForeignPtr other-modules: Data.Prim.Memory.Bytes.Internal - build-depends: base >= 4.8 && < 5 - , bytestring + build-depends: base >= 4.9 && < 5 + , bytestring >= 0.10.4 , deepseq - , primal + , primal >= 0.2 + , text >= 1.1.1.3 default-language: Haskell2010 ghc-options: -Wall --- test-suite doctests --- type: exitcode-stdio-1.0 --- hs-source-dirs: tests --- main-is: doctests.hs --- build-depends: base --- , doctest >=0.15 --- , prim-bytes --- , template-haskell --- default-language: Haskell2010 --- ghc-options: -Wall --- -fno-warn-orphans --- -threaded + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + , bytestring + , doctest >=0.15 + , primal + , primal-memory + , QuickCheck + , template-haskell + default-language: Haskell2010 + ghc-options: -Wall + -threaded + benchmark bench type: exitcode-stdio-1.0 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 @@ -7,83 +7,100 @@ -- Portability : non-portable -- module Data.Prim.Memory - ( Pinned(..) + ( module Data.Prim + , Pinned(..) -- * Immutable , Bytes , MemRead - , countMem - , countRemMem - , indexOffMem - , eqMem - , compareMem + -- ** Size + , countMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , countRemMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , byteCountMem -- DOC: [x], DOCTEST [ ], TEST: [x] + -- ** Index + , indexOffMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , indexByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [x] + -- ** Construct + , emptyMem -- DOC: [x], DOCTEST [x], TEST: [x] + , singletonMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , cycleMemN -- DOC: [x], DOCTEST [x], TEST: [ ] + , createMemST -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , createMemST_ -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , createZeroMemST -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , createZeroMemST_ -- DOC: [x], DOCTEST [x], TEST: [ ] + -- ** Copy + , cloneMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , copyMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , copyByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , copyByteOffToMBytesMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , copyByteOffToPtrMem -- DOC: [x], DOCTEST [ ], TEST: [x] + -- ** Compare + , eqMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , compareMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , compareByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , compareByteOffToPtrMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , compareByteOffToBytesMem -- DOC: [x], DOCTEST [ ], TEST: [x] + -- ** Convert + , convertMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + -- *** To list + , toListMem -- DOC: [x], DOCTEST [x], TEST: [x] + , toListSlackMem -- DOC: [x], DOCTEST [x], TEST: [x] + , toByteListMem -- DOC: [x], DOCTEST [x], TEST: [x] + , foldrCountMem -- DOC: [x], DOCTEST [-], TEST: [-] + , showsHexMem -- DOC: [x], DOCTEST [x], TEST: [ ] + + -- *** From list + , fromListMem -- DOC: [x], DOCTEST [x], TEST: [x] + , fromByteListMem -- DOC: [x], DOCTEST [x], TEST: [x] + , fromListMemN -- DOC: [x], DOCTEST [x], TEST: [x] + , fromListZeroMemN -- DOC: [x], DOCTEST [x], TEST: [ ] + , fromListZeroMemN_ -- DOC: [x], DOCTEST [x], TEST: [ ] -- * Mutable , MBytes - , MemAlloc(FrozenMem) , MemWrite - , getCountMem - , getCountRemMem - , readOffMem - , writeOffMem - , modifyFetchOldMem - , modifyFetchOldMemM - , modifyFetchNewMem - , modifyFetchNewMemM - , setMem - , copyMem - , moveMem - + , MemAlloc(FrozenMem) , MemState(..) - , allocMem - , allocZeroMem - , thawMem - , thawCloneMem - , thawCopyMem - , freezeMem - , freezeCloneMem - , freezeCopyMem - , createMemST - , createMemST_ - , createZeroMemST - , createZeroMemST_ - , emptyMem - , singletonMem - , cycleMemN - -- * Byte operations - -- $byteOperations - -- ** Immutable - , byteCountMem - , indexByteOffMem - , compareByteOffMem - -- ** Mutable - , allocByteCountMem - , getByteCountMem - , readByteOffMem - , writeByteOffMem - , copyByteOffMem - , moveByteOffMem - -- * Conversion - , convertMem - -- ** List - , toListMem - , toListSlackMem - , toByteListMem - , fromByteListMem - - , fromListMem - , fromListMemN - , loadListMem - , loadListMem_ - , loadListMemN - , loadListMemN_ - -- *** Helpers - , foldrCountMem + -- ** Size + , getCountMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , getCountRemMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , getByteCountMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + -- ** Read + , readOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , readByteOffMem -- 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: [ ] + -- ** 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: [ ] + -- ** Move + , moveMem -- DOC: [ ], DOCTEST [ ], TEST: [x] + , moveByteOffMem -- DOC: [x], DOCTEST [ ], TEST: [ ] + , moveByteOffToMBytesMem -- DOC: [x], DOCTEST [ ], TEST: [x] + , moveByteOffToPtrMem -- 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: [ ] + -- *** With offset + , loadListOffMem -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , loadListOffMemN -- DOC: [ ], DOCTEST [ ], TEST: [ ] + , loadListByteOffMem -- DOC: [x], DOCTEST [x], TEST: [ ] + , loadListByteOffMemN -- DOC: [x], DOCTEST [x], TEST: [ ] ) where +import Data.Prim import Data.Prim.Memory.Internal - - --- $byteOperations --- --- More often than not it is desired to operate on the offset and count of the actual type --- of intereset we are dealing with in memory. But sometimes it is necessary to specify --- things in 8bit steps, this is where byte size offsets and counts will come in handy. 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 @@ -134,26 +134,29 @@ import Data.Prim.Atomic import Data.Prim.Class import Data.Prim.Memory.Bytes +import Data.Prim.Memory.Bytes.Internal import Data.Prim.Memory.ByteString import Data.Prim.Memory.ForeignPtr import Data.Prim.Memory.Internal import Data.Prim.Memory.Ptr import qualified Data.Semigroup as Semigroup import Foreign.Prim +import Unsafe.Coerce +-- | Immutable read-only address data Addr e = Addr { addrAddr# :: Addr# , addrBytes :: {-# UNPACK #-}!(Bytes 'Pin) } -type role Addr representational - +type role Addr nominal +-- | Mutable address data MAddr e s = MAddr { mAddrAddr# :: Addr# , mAddrMBytes :: {-# UNPACK #-}!(MBytes 'Pin s) } -type role MAddr representational nominal +type role MAddr nominal nominal @@ -169,7 +172,7 @@ instance Prim e => IsList (Addr e) where type Item (Addr e) = e fromList = fromListMem - fromListN n = fromListMemN_ (Count n) + fromListN n = fromListZeroMemN_ (Count n) toList = toListMem instance Semigroup.Semigroup (Addr e) where @@ -189,6 +192,9 @@ castMAddr :: MAddr e s -> MAddr b s castMAddr (MAddr a mb) = MAddr a mb +castStateMAddr :: MAddr e s' -> MAddr b s +castStateMAddr = unsafeCoerce + isSameAddr :: Addr e -> Addr e -> Bool isSameAddr (Addr a1# _) (Addr a2# _) = isTrue# (a1# `eqAddr#` a2#) @@ -245,13 +251,13 @@ plusOffAddr :: Prim e => Addr e -> Off e -> Addr e -plusOffAddr (Addr addr# b) off = Addr (addr# `plusAddr#` fromOff# off) b +plusOffAddr (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#` fromOff# off) mb +plusOffMAddr (MAddr addr# mb) off = MAddr (addr# `plusAddr#` unOffBytes# off) mb curOffAddr :: Prim e => Addr e -> Off e -curOffAddr a@(Addr addr# b) = offAsProxy a (Ptr addr# `minusOffPtr` toPtrBytes b) +curOffAddr a@(Addr addr# b) = (Ptr addr# `minusOffPtr` toPtrBytes b) `offForProxyTypeOf` a curByteOffAddr :: Addr e -> Off Word8 curByteOffAddr (Addr addr# b) = Ptr addr# `minusByteOffPtr` toPtrBytes b @@ -314,32 +320,40 @@ toForeignPtrMAddr :: MAddr e s -> ForeignPtr e toForeignPtrMAddr (MAddr addr# (MBytes mba#)) = ForeignPtr addr# (PlainPtr (unsafeCoerce# mba#)) --- | Discarding the original `ForeignPtr` will trigger finalizers that were attached to --- it, because `Addr` does not retain any finalizers. This is a unsafe cast therefore --- modification of `ForeignPtr` will be reflected in resulting immutable `Addr`. Pointer --- created with @malloc@ cannot be converted to `Addr` and will result in `Nothing` +-- | This is a unsafe cast therefore modification of `ForeignPtr` will be reflected in +-- resulting immutable `Addr`. Pointer created with @malloc@ cannot be converted to `Addr` +-- and will result in `Nothing` -- -- @since 0.1.0 fromForeignPtrAddr :: ForeignPtr e -> Maybe (Addr e) -fromForeignPtrAddr (ForeignPtr addr# c) = - case c of - PlainPtr mba# -> Just (Addr addr# (unsafePerformIO (freezeMBytes (MBytes mba#)))) - MallocPtr mba# _ -> Just (Addr addr# (unsafePerformIO (freezeMBytes (MBytes mba#)))) - _ -> Nothing +fromForeignPtrAddr fptr = + unsafePerformIO $ fromForeignPtrIO fptr >>= traverse freezeMAddr + -- | Discarding the original ForeignPtr will trigger finalizers that were attached to it, -- because `MAddr` does not retain any finalizers. Pointer created with @malloc@ cannot be -- converted to `MAddr` and will result in `Nothing` -- -- @since 0.1.0 fromForeignPtrMAddr :: ForeignPtr e -> Maybe (MAddr e s) -fromForeignPtrMAddr (ForeignPtr addr# c) = - case c of - PlainPtr mba# -> Just (MAddr addr# (MBytes (unsafeCoerce# mba#))) - MallocPtr mba# _ -> Just (MAddr addr# (MBytes (unsafeCoerce# mba#))) - _ -> Nothing +fromForeignPtrMAddr fptr = + unsafePerformIO (fmap castStateMAddr <$> fromForeignPtrIO fptr) + -- case c of + -- PlainPtr mba# -> Just (MAddr addr# (MBytes (unsafeCoerce# mba#))) + -- MallocPtr mba# _ -> Just (MAddr addr# (MBytes (unsafeCoerce# mba#))) + -- _ -> Nothing +fromForeignPtrIO :: ForeignPtr e -> IO (Maybe (MAddr e RW)) +fromForeignPtrIO fptr = + onForeignPtrContents fptr checkConvert $ \_ -> pure Nothing + where + checkConvert addr# mba# checkFinalizers = do + hasFinalizers <- checkFinalizers + pure $ + if hasFinalizers + then Nothing + else Just (MAddr addr# (MBytes mba#)) withAddrMAddr# :: MonadPrim s m => MAddr e s -> (Addr# -> m b) -> m b withAddrMAddr# (MAddr addr# mb) f = do @@ -374,11 +388,10 @@ instance MemAlloc (MAddr e) where type FrozenMem (MAddr e) = Addr e - getByteCountMem = getByteCountMAddr {-# INLINE getByteCountMem #-} - allocByteCountMem = fmap castMAddr . allocMAddr - {-# INLINE allocByteCountMem #-} + allocMem = fmap castMAddr . allocMAddr + {-# INLINE allocMem #-} thawMem = thawAddr {-# INLINE thawMem #-} freezeMem = freezeMAddr @@ -404,7 +417,8 @@ withPtrAccess addr $ \ptr1 -> pure $ compareByteOffPtrToPtr ptr1 off1 ptr2 off2 c {-# INLINE compareByteOffToPtrMem #-} compareByteOffToBytesMem addr off1 bytes off2 c = - withPtrAccess addr $ \ptr1 -> pure $ compareByteOffPtrToBytes ptr1 off1 bytes off2 c + unsafeInlineIO $ withPtrAccess addr $ \ptr1 -> + pure $! compareByteOffPtrToBytes ptr1 off1 bytes off2 c {-# INLINE compareByteOffToBytesMem #-} compareByteOffMem mem1 off1 addr off2 c = unsafeInlineIO $ withPtrAccess addr $ \ptr2 -> compareByteOffToPtrMem mem1 off1 ptr2 off2 c @@ -533,7 +547,7 @@ toShortByteStringAddr :: Addr Word8 -> (ShortByteString, Off Word8) toShortByteStringAddr = first toShortByteStringBytes . toBytesAddr --- | /O(1)/ - Cast an immutable `ShortByteString` to an immutable `Addr`. In a most common +-- | /O(n)/ - Convert an immutable `ShortByteString` to an immutable `Addr`. In a most common -- case when `ShortByteString` is not backed by pinned memory, this function will return -- `Nothing`. -- @@ -549,7 +563,7 @@ fromByteStringAddr (PS fptr i n) = case fromForeignPtrAddr fptr of Just addr -> (addr `plusOffAddr` Off i, Count n) - Nothing -> byteStringConvertError "It was allocated outside of 'bytestring' package" + Nothing -> byteStringConvertError "ByteString was allocated outside of 'bytestring' package" -- | /O(1)/ - Cast an immutable `ByteString` to a mutable `MAddr`. Also returns the -- original length of ByteString, which will be less or equal to `getCountOfMAddr` in the @@ -1026,33 +1040,33 @@ prefetchOffAddr0 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m () -prefetchOffAddr0 (Addr addr# _) off = prim_ (prefetchAddr0# addr# (fromOff# off)) +prefetchOffAddr0 (Addr addr# _) off = prim_ (prefetchAddr0# addr# (unOffBytes# off)) {-# INLINE prefetchOffAddr0 #-} prefetchOffMAddr0 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m () -prefetchOffMAddr0 (MAddr maddr# _) off = prim_ (prefetchAddr0# maddr# (fromOff# off)) +prefetchOffMAddr0 (MAddr maddr# _) off = prim_ (prefetchAddr0# maddr# (unOffBytes# off)) {-# INLINE prefetchOffMAddr0 #-} prefetchOffAddr1 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m () -prefetchOffAddr1 (Addr addr# _) off = prim_ (prefetchAddr1# addr# (fromOff# off)) +prefetchOffAddr1 (Addr addr# _) off = prim_ (prefetchAddr1# addr# (unOffBytes# off)) {-# INLINE prefetchOffAddr1 #-} prefetchOffMAddr1 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m () -prefetchOffMAddr1 (MAddr maddr# _) off = prim_ (prefetchAddr1# maddr# (fromOff# off)) +prefetchOffMAddr1 (MAddr maddr# _) off = prim_ (prefetchAddr1# maddr# (unOffBytes# off)) {-# INLINE prefetchOffMAddr1 #-} prefetchOffAddr2 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m () -prefetchOffAddr2 (Addr addr# _) off = prim_ (prefetchAddr2# addr# (fromOff# off)) +prefetchOffAddr2 (Addr addr# _) off = prim_ (prefetchAddr2# addr# (unOffBytes# off)) {-# INLINE prefetchOffAddr2 #-} prefetchOffMAddr2 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m () -prefetchOffMAddr2 (MAddr maddr# _) off = prim_ (prefetchAddr2# maddr# (fromOff# off)) +prefetchOffMAddr2 (MAddr maddr# _) off = prim_ (prefetchAddr2# maddr# (unOffBytes# off)) {-# INLINE prefetchOffMAddr2 #-} prefetchOffAddr3 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m () -prefetchOffAddr3 (Addr addr# _) off = prim_ (prefetchAddr3# addr# (fromOff# off)) +prefetchOffAddr3 (Addr addr# _) off = prim_ (prefetchAddr3# addr# (unOffBytes# off)) {-# INLINE prefetchOffAddr3 #-} prefetchOffMAddr3 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m () -prefetchOffMAddr3 (MAddr maddr# _) off = prim_ (prefetchAddr3# maddr# (fromOff# off)) +prefetchOffMAddr3 (MAddr maddr# _) off = prim_ (prefetchAddr3# maddr# (unOffBytes# off)) {-# INLINE prefetchOffMAddr3 #-} diff --git a/src/Data/Prim/Memory/ByteArray.hs b/src/Data/Prim/Memory/ByteArray.hs deleted file mode 100644 --- a/src/Data/Prim/Memory/ByteArray.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Prim.Memory.ByteArray --- Copyright : (c) Alexey Kuleshevich 2020 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Prim.Memory.ByteArray - ( ByteArray(..) - , MByteArray(..) - , Pinned(..) - , fromBytesByteArray - , toBytesByteArray - , castByteArray - , fromMBytesMByteArray - , toMBytesMByteArray - , castMByteArray - , allocMByteArray - , allocPinnedMByteArray - , allocAlignedMByteArray - , allocUnpinnedMByteArray - , shrinkMByteArray - , resizeMByteArray - , reallocMByteArray - , isPinnedByteArray - , isPinnedMByteArray - - , thawByteArray - , freezeMByteArray - , sizeByteArray - , getSizeMByteArray - , readMByteArray - , writeMByteArray - - , setMByteArray - , copyByteArrayToMByteArray - , moveMByteArrayToMByteArray - ) 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 ByteArray (p :: Pinned) e = ByteArray (Bytes p) - deriving (NFData, Semigroup, Monoid, MemRead) -type role ByteArray nominal nominal - --- | A mutable array of bytes of type @e@ -newtype MByteArray (p :: Pinned) e s = MByteArray (MBytes p s) - deriving (NFData, MemWrite) -type role MByteArray nominal nominal nominal - --- | Read-only access, but it is not enforced. -instance PtrAccess s (ByteArray 'Pin e) where - toForeignPtr = pure . toForeignPtrBytes . toBytesByteArray - {-# INLINE toForeignPtr #-} - withPtrAccess b = withPtrBytes (toBytesByteArray b) - {-# INLINE withPtrAccess #-} - withNoHaltPtrAccess b = withNoHaltPtrBytes (toBytesByteArray b) - {-# INLINE withNoHaltPtrAccess #-} - -instance PtrAccess s (MByteArray 'Pin e s) where - toForeignPtr = pure . toForeignPtrMBytes . toMBytesMByteArray - {-# INLINE toForeignPtr #-} - withPtrAccess mb = withPtrMBytes (toMBytesMByteArray mb) - {-# INLINE withPtrAccess #-} - withNoHaltPtrAccess mb = withNoHaltPtrMBytes (toMBytesMByteArray mb) - {-# INLINE withNoHaltPtrAccess #-} - -instance Typeable p => MemAlloc (MByteArray p e) where - type FrozenMem (MByteArray p e) = ByteArray p e - getByteCountMem = getByteCountMem . toMBytesMByteArray - {-# INLINE getByteCountMem #-} - allocByteCountMem = fmap fromMBytesMByteArray . allocMBytes - {-# INLINE allocByteCountMem #-} - thawMem = thawByteArray - {-# INLINE thawMem #-} - freezeMem = freezeMByteArray - {-# INLINE freezeMem #-} - resizeMem mba = fmap fromMBytesMByteArray . reallocMBytes (toMBytesMByteArray mba) - {-# INLINE resizeMem #-} - -instance (Typeable p, Prim e) => IsList (ByteArray p e) where - type Item (ByteArray p e) = e - fromList = fromListMem - fromListN n = fromListMemN_ (Count n) - toList = toListMem - -instance Typeable p => IsString (ByteArray p Char) where - fromString = fromListMem - -instance (Show e, Prim e) => Show (ByteArray p e) where - show = show . toListByteArray - - -toListByteArray :: Prim e => ByteArray p e -> [e] -toListByteArray = toListMem - -castByteArray :: ByteArray p e' -> ByteArray p e -castByteArray = coerce - -fromBytesByteArray :: Bytes p -> ByteArray p e -fromBytesByteArray = coerce - -toBytesByteArray :: ByteArray p e -> Bytes p -toBytesByteArray = coerce - -castMByteArray :: MByteArray p e' s -> MByteArray p e s -castMByteArray = coerce - -fromMBytesMByteArray :: MBytes p s -> MByteArray p e s -fromMBytesMByteArray = coerce - -toMBytesMByteArray :: MByteArray p e s -> MBytes p s -toMBytesMByteArray = coerce - -sizeByteArray :: forall e p. Prim e => ByteArray p e -> Size -sizeByteArray = (coerce :: Count e -> Size) . countBytes . toBytesByteArray -{-# INLINE sizeByteArray #-} - -getSizeMByteArray :: forall e p m s. (MonadPrim s m, Prim e) => MByteArray p e s -> m Size -getSizeMByteArray = fmap (coerce :: Count e -> Size) . getCountMBytes . toMBytesMByteArray -{-# INLINE getSizeMByteArray #-} - -allocMByteArray :: - forall e p m s . (Typeable p, Prim e, MonadPrim s m) => Size -> m (MByteArray p e s) -allocMByteArray sz = fromMBytesMByteArray <$> allocMBytes (coerce sz :: Count e) -{-# INLINE allocMByteArray #-} - -allocUnpinnedMByteArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MByteArray 'Inc e s) -allocUnpinnedMByteArray sz = fromMBytesMByteArray <$> allocUnpinnedMBytes (coerce sz :: Count e) -{-# INLINE allocUnpinnedMByteArray #-} - -allocPinnedMByteArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MByteArray 'Pin e s) -allocPinnedMByteArray sz = fromMBytesMByteArray <$> allocPinnedMBytes (coerce sz :: Count e) -{-# INLINE allocPinnedMByteArray #-} - -allocAlignedMByteArray :: - (MonadPrim s m, Prim e) - => Count e -- ^ Size in number of bytes - -> m (MByteArray 'Pin e s) -allocAlignedMByteArray = fmap fromMBytesMByteArray . allocAlignedMBytes -{-# INLINE allocAlignedMByteArray #-} - -freezeMByteArray :: MonadPrim s m => MByteArray p e s -> m (ByteArray p e) -freezeMByteArray = fmap fromBytesByteArray . freezeMBytes . toMBytesMByteArray -{-# INLINE freezeMByteArray #-} - -thawByteArray :: MonadPrim s m => ByteArray p e -> m (MByteArray p e s) -thawByteArray = fmap fromMBytesMByteArray . thawBytes . toBytesByteArray -{-# INLINE thawByteArray #-} - --- | 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 `getCountMByteArray`. -shrinkMByteArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MByteArray p e s - -> Size - -> m () -shrinkMByteArray mba sz = shrinkMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) -{-# INLINE shrinkMByteArray #-} - - --- | 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 -resizeMByteArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MByteArray p e s - -> Size - -> m (MByteArray 'Inc e s) -resizeMByteArray mba sz = - fromMBytesMByteArray <$> - resizeMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) -{-# INLINE resizeMByteArray #-} - -reallocMByteArray :: - forall e p m s. (MonadPrim s m, Typeable p, Prim e) - => MByteArray p e s - -> Size - -> m (MByteArray p e s) -reallocMByteArray mba sz = - fromMBytesMByteArray <$> - reallocMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) -{-# INLINABLE reallocMByteArray #-} - - -isPinnedByteArray :: ByteArray p e -> Bool -isPinnedByteArray (ByteArray b) = isPinnedBytes b -{-# INLINE isPinnedByteArray #-} - -isPinnedMByteArray :: MByteArray p e s -> Bool -isPinnedMByteArray (MByteArray mb) = isPinnedMBytes mb -{-# INLINE isPinnedMByteArray #-} - -readMByteArray :: (MonadPrim s m, Prim e) => MByteArray p e s -> Int -> m e -readMByteArray (MByteArray mb) = readOffMBytes mb . coerce -{-# INLINE readMByteArray #-} - -writeMByteArray :: (MonadPrim s m, Prim e) => MByteArray p e s -> Int -> e -> m () -writeMByteArray (MByteArray mb) o = writeOffMBytes mb (coerce o) -{-# INLINE writeMByteArray #-} - - - -setMByteArray :: - (MonadPrim s m, Prim e) - => MByteArray 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 () -setMByteArray (MByteArray mb) off sz = setMBytes mb (coerce off) (coerce sz) -{-# INLINE setMByteArray #-} - -copyByteArrayToMByteArray :: - (MonadPrim s m, Prim e) - => ByteArray p e - -> Int - -> MByteArray p e s - -> Int - -> Size - -> m () -copyByteArrayToMByteArray ba srcOff mba dstOff sz = - copyMem ba (coerce srcOff) mba (coerce dstOff) (countAsProxy ba (coerce sz)) -{-# INLINE copyByteArrayToMByteArray #-} - -moveMByteArrayToMByteArray :: - forall e p m s. (MonadPrim s m, Prim e) - => MByteArray p e s - -> Int - -> MByteArray p e s - -> Int - -> Size - -> m () -moveMByteArrayToMByteArray ba srcOff mba dstOff sz = - moveMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz :: Count e) -{-# INLINE moveMByteArrayToMByteArray #-} - - - --- toPtrByteArray :: ByteArray Pin e -> Ptr e --- toPtrByteArray (ByteArray ba#) = Ptr (byteArrayContents# ba#) --- {-# INLINE toPtrByteArray #-} - --- toPtrMByteArray :: MByteArray Pin e s -> Ptr e --- toPtrMByteArray (MByteArray mba#) = Ptr (mutableByteArrayContents# mba#) --- {-# INLINE toPtrMByteArray #-} - --- -- | Pointer access to immutable `ByteArray` should be for read only purposes, but it is --- -- not enforced. Any mutation will break referential transparency --- withPtrByteArray :: MonadPrim s m => ByteArray Pin e -> (Ptr e -> m b) -> m b --- withPtrByteArray b f = do --- res <- f (toPtrByteArray b) --- res <$ touch b --- {-# INLINE withPtrByteArray #-} - --- -- | Same as `withPtrByteArray`, but is suitable for actions that don't terminate --- withNoHaltPtrByteArray :: MonadUnliftPrim s m => ByteArray Pin e -> (Ptr e -> m b) -> m b --- withNoHaltPtrByteArray b f = withAliveUnliftPrim b $ f (toPtrByteArray b) --- {-# INLINE withNoHaltPtrByteArray #-} - --- withPtrMByteArray :: MonadPrim s m => MByteArray Pin e s -> (Ptr e -> m b) -> m b --- withPtrMByteArray mb f = do --- res <- f (toPtrMByteArray mb) --- res <$ touch mb --- {-# INLINE withPtrMByteArray #-} - --- withNoHaltPtrMByteArray :: MonadUnliftPrim s m => MByteArray Pin e s -> (Ptr e -> m b) -> m b --- withNoHaltPtrMByteArray mb f = withAliveUnliftPrim mb $ f (toPtrMByteArray mb) --- {-# INLINE withNoHaltPtrMByteArray #-} - - --- -- -- | Check if two byte arrays refer to pinned memory and compare their pointers. --- -- isSameByteArray :: ByteArray p1 e -> ByteArray p2 e -> Bool --- -- isSameByteArray (ByteArray b1#) (ByteArray b2#) = isTrue# (isSameByteArray# b1# b2#) --- -- {-# INLINE[0] isSameByteArray #-} --- -- {-# RULES --- -- "isSamePinnedByteArray" isSameByteArray = isSamePinnedByteArray --- -- #-} - --- -- -- | Perform pointer equality on pinned `ByteArray`. --- -- isSamePinnedByteArray :: ByteArray Pin e -> ByteArray Pin e -> Bool --- -- isSamePinnedByteArray pb e1 pb2 = toPtrByteArray pb e1 == toPtrByteArray pb e2 --- -- {-# INLINE isSamePinnedByteArray #-} - - - --- -- byteStringConvertError :: String -> a --- -- byteStringConvertError msg = error $ "Cannot convert 'ByteString'. " ++ msg --- -- {-# NOINLINE byteStringConvertError #-} - 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MagicHash #-} -- | @@ -34,6 +35,7 @@ import Data.ByteString.Builder import Data.ByteString.Internal import Data.ByteString.Short.Internal +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Prim import Foreign.Prim @@ -46,8 +48,9 @@ , allocMBytes , freezeMBytes , byteCountBytes + , relaxPinnedBytes , toForeignPtrBytes - , fromForeignPtrBytes + , castForeignPtrToBytes , byteStringConvertError ) @@ -55,13 +58,39 @@ newtype MByteString s = MByteString ByteString --- | /O(1)/ - Cast an immutable `Bytes` to an immutable `ByteString` +-- | /O(1)/ - Cast immutable `Bytes` to an immutable `ByteString` -- -- @since 0.1.0 toByteStringBytes :: Bytes 'Pin -> ByteString -toByteStringBytes b = PS (toForeignPtrBytes b) 0 (coerce (byteCountBytes b)) {-# INLINE toByteStringBytes #-} +toByteStringBytes b = +#if MIN_VERSION_bytestring(0,11,0) + BS (toForeignPtrBytes b) (coerce (byteCountBytes b)) +#else + PS (toForeignPtrBytes b) 0 (coerce (byteCountBytes b)) +#endif + +-- | /O(1)/ - Cast an immutable `ByteString` to immutable `Bytes`. Only unsliced +-- `ByteString`s that are backed by a `ForeignPtr` allocated on Haskell heap without +-- finilizers can be converted without copy. +-- +-- @since 0.2.0 +castByteStringBytes :: ByteString -> Either String (Bytes 'Pin) +#if MIN_VERSION_bytestring(0,11,0) +castByteStringBytes (BS fptr n) = do +#else +castByteStringBytes (PS fptr o n) = do + unless (o == 0) sliceError +#endif + b <- castForeignPtrToBytes fptr + unless (unCount (byteCountBytes b) == n) sliceError + Right b + where + sliceError = Left "ByteString was sliced" +{-# INLINE castByteStringBytes #-} + + -- | /O(1)/ - Cast an immutable `Bytes` to an immutable `ShortByteString` -- -- @since 0.1.0 @@ -92,32 +121,43 @@ -- | /O(n)/ - Allocate `Bytes` and fill them with the contents of a lazy `BSL.ByteString` fromLazyByteStringBytes :: BSL.ByteString -> Bytes 'Pin -fromLazyByteStringBytes bsl = - case BSL.toStrict bsl of - PS fptr _ _ -> either byteStringConvertError id $ fromForeignPtrBytes fptr +fromLazyByteStringBytes = fromByteStringBytes . BSL.toStrict {-# INLINE fromLazyByteStringBytes #-} --- | /O(n)/ - Allocate `Bytes` and fill them with the contents of a strict `ByteString` +-- | /O(n)/ - Convert a strict `ByteString` to `Bytes`. fromByteStringBytes :: Typeable p => ByteString -> Bytes p -fromByteStringBytes bs@(PS _ _ n) = - runST $ - withPtrByteString bs $ \ptr -> do - let c = Count n :: Count Word8 - mb <- allocMBytes c - movePtrToMBytes ptr 0 mb 0 c - freezeMBytes mb +fromByteStringBytes bs = + case castByteStringBytes bs of + Right b -> relaxPinnedBytes b + Left _ -> + runST $ + withPtrByteString bs $ \ptr -> do + let c = Count (BS.length bs) :: Count Word8 + mb <- allocMBytes c + copyPtrToMBytes ptr 0 mb 0 c + freezeMBytes mb {-# INLINE fromByteStringBytes #-} withPtrByteString :: MonadPrim s m => ByteString -> (Ptr a -> m b) -> m b -withPtrByteString (PS (ForeignPtr addr# ptrContents) (I# o#) _) f = do - r <- f (Ptr (addr# `plusAddr#` o#)) +#if MIN_VERSION_bytestring(0,11,0) +withPtrByteString (BS (ForeignPtr addr# ptrContents) _) f = do +#else +withPtrByteString (PS (ForeignPtr addr'# ptrContents) (I# o#) _) f = do + let addr# = addr'# `plusAddr#` o# +#endif + r <- f (Ptr addr#) r <$ touch ptrContents {-# INLINE withPtrByteString #-} withNoHaltPtrByteString :: MonadUnliftPrim s m => ByteString -> (Ptr a -> m b) -> m b -withNoHaltPtrByteString (PS (ForeignPtr addr# ptrContents) (I# o#) _) f = - withAliveUnliftPrim ptrContents $ f (Ptr (addr# `plusAddr#` o#)) +#if MIN_VERSION_bytestring(0,11,0) +withNoHaltPtrByteString (BS (ForeignPtr addr# ptrContents) _) f = do +#else +withNoHaltPtrByteString (PS (ForeignPtr addr'# ptrContents) (I# o#) _) f = do + let addr# = addr'# `plusAddr#` o# +#endif + withAliveUnliftPrim 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 @@ -6,7 +6,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Prim.Memory.Bytes @@ -36,6 +35,8 @@ , isPinnedMBytes , toPinnedBytes , toPinnedMBytes + , toInconclusiveBytes + , toInconclusiveMBytes , relaxPinnedBytes , relaxPinnedMBytes , ensurePinnedBytes @@ -155,7 +156,6 @@ import Data.Prim import Data.Prim.Atomic import Data.Prim.Memory.Internal -import Data.Prim.Memory.Bytes.Internal import Foreign.Prim -- | Wrap `ByteArray#` into `Bytes` @@ -176,7 +176,6 @@ - -- | 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#) @@ -188,17 +187,9 @@ ---- Pure --- -- This works exactly the same as `compareBytes` except it is implemented with FFI --- -- call instead of a primop. It will probably prove to be useless and will be removed in --- -- the future. --- memcmpBytes :: Prim e => Bytes p1 -> Off e -> Bytes p2 -> Off e -> Count e -> Ordering --- memcmpBytes (Bytes ba1#) off1 (Bytes ba2#) off2 c = --- toOrdering# (memcmpByteArray# ba1# (fromOff# off1) ba2# (fromOff# off2) (fromCount# c)) --- {-# INLINE memcmpBytes #-} - compareBytes :: Prim e => Bytes p1 -> Off e -> Bytes p2 -> Off e -> Count e -> Ordering compareBytes (Bytes b1#) off1 (Bytes b2#) off2 c = - toOrdering# (compareByteArrays# b1# (fromOff# off1) b2# (fromOff# off2) (fromCount# c)) + toOrdering# (compareByteArrays# b1# (unOffBytes# off1) b2# (unOffBytes# off2) (unCountBytes# c)) {-# INLINE compareBytes #-} @@ -244,14 +235,14 @@ (MonadPrim s m, Prim e) => Bytes ps -> Off e -> MBytes pd s -> Off e -> Count e -> m () copyBytesToMBytes (Bytes src#) srcOff (MBytes dst#) dstOff c = prim_ $ - copyByteArray# src# (fromOff# srcOff) dst# (fromOff# dstOff) (fromCount# c) + copyByteArray# src# (unOffBytes# srcOff) dst# (unOffBytes# dstOff) (unCountBytes# c) {-# INLINE copyBytesToMBytes #-} moveMBytesToMBytes :: (MonadPrim s m, Prim e) => MBytes ps s-> Off e -> MBytes pd s -> Off e -> Count e -> m () moveMBytesToMBytes (MBytes src#) srcOff (MBytes dst#) dstOff c = - prim_ (copyMutableByteArray# src# (fromOff# srcOff) dst# (fromOff# dstOff) (fromCount# c)) + prim_ (copyMutableByteArray# src# (unOffBytes# srcOff) dst# (unOffBytes# dstOff) (unCountBytes# c)) {-# INLINE moveMBytesToMBytes #-} -- | Allocated memory is not cleared, so make sure to fill it in properly, otherwise you @@ -370,36 +361,27 @@ toListSlackBytes = toListSlackMem {-# INLINE toListSlackBytes #-} --- | Returns `EQ` if the full list did fit into the supplied memory chunk exactly. --- Otherwise it will return either `LT` if the list was smaller than allocated memory or --- `GT` if the list was bigger than the available memory and did not fit into `MBytes`. -loadListMBytes :: (MonadPrim s m, Prim e) => [e] -> MBytes p s -> m Ordering -loadListMBytes ys mb = do - (c, slack) <- getCountRemOfMBytes mb - loadListMemN (countAsProxy ys c) slack ys mb +-- | Same as `loadListMem` +loadListMBytes :: (Prim e, Typeable p, MonadPrim s m) => [e] -> MBytes p s -> m ([e], Count e) +loadListMBytes = loadListMem {-# INLINE loadListMBytes #-} -loadListMBytes_ :: (MonadPrim s m, Prim e) => [e] -> MBytes p s -> m () -loadListMBytes_ ys mb = do - c <- getCountMBytes mb - loadListMemN_ (countAsProxy ys c) ys mb +-- | Same as `loadListMem_` +loadListMBytes_ :: (Prim e, Typeable p, MonadPrim s m) => [e] -> MBytes p s -> m () +loadListMBytes_ = loadListMem_ {-# INLINE loadListMBytes_ #-} +-- | Same as `fromListZeroMemN_` fromListBytesN_ :: (Prim e, Typeable p) => Count e -> [e] -> Bytes p -fromListBytesN_ = fromListMemN_ +fromListBytesN_ = fromListZeroMemN_ {-# INLINE fromListBytesN_ #-} --- | If the list is bigger than the supplied @`Count` a@ then `GT` ordering will be --- returned, along with the `Bytes` fully filled with the prefix of the list. On the other --- hand if the list is smaller than the supplied `Count`, `LT` with partially filled --- `Bytes` will returned. In the latter case expect some garbage at the end of the --- allocated memory, since no attempt is made to zero it out. Exact match obviously --- results in an `EQ`. +-- | Exactly like `fromListMemN`, but restricted to `Bytes`. fromListBytesN :: (Prim e, Typeable p) => Count e -> [e] - -> (Ordering, Bytes p) + -> (Either [e] (Count e), Bytes p) fromListBytesN = fromListMemN {-# INLINE fromListBytesN #-} @@ -424,14 +406,7 @@ concatBytes = concatMem {-# INLINE concatBytes #-} -relaxPinnedBytes :: Bytes p -> Bytes 'Inc -relaxPinnedBytes = castPinnedBytes -relaxPinnedMBytes :: MBytes p e -> MBytes 'Inc e -relaxPinnedMBytes = castPinnedMBytes - - - ensurePinnedBytes :: Bytes p -> Bytes 'Pin ensurePinnedBytes b = fromMaybe (convertMem b) (toPinnedBytes b) {-# INLINE ensurePinnedBytes #-} @@ -906,34 +881,34 @@ prefetchBytes0 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m () -prefetchBytes0 (Bytes b#) off = prim_ (prefetchByteArray0# b# (fromOff# off)) +prefetchBytes0 (Bytes b#) off = prim_ (prefetchByteArray0# b# (unOffBytes# off)) {-# INLINE prefetchBytes0 #-} prefetchMBytes0 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m () -prefetchMBytes0 (MBytes mb#) off = prim_ (prefetchMutableByteArray0# mb# (fromOff# off)) +prefetchMBytes0 (MBytes mb#) off = prim_ (prefetchMutableByteArray0# mb# (unOffBytes# off)) {-# INLINE prefetchMBytes0 #-} prefetchBytes1 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m () -prefetchBytes1 (Bytes b#) off = prim_ (prefetchByteArray1# b# (fromOff# off)) +prefetchBytes1 (Bytes b#) off = prim_ (prefetchByteArray1# b# (unOffBytes# off)) {-# INLINE prefetchBytes1 #-} prefetchMBytes1 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m () -prefetchMBytes1 (MBytes mb#) off = prim_ (prefetchMutableByteArray1# mb# (fromOff# off)) +prefetchMBytes1 (MBytes mb#) off = prim_ (prefetchMutableByteArray1# mb# (unOffBytes# off)) {-# INLINE prefetchMBytes1 #-} prefetchBytes2 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m () -prefetchBytes2 (Bytes b#) off = prim_ (prefetchByteArray2# b# (fromOff# off)) +prefetchBytes2 (Bytes b#) off = prim_ (prefetchByteArray2# b# (unOffBytes# off)) {-# INLINE prefetchBytes2 #-} prefetchMBytes2 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m () -prefetchMBytes2 (MBytes mb#) off = prim_ (prefetchMutableByteArray2# mb# (fromOff# off)) +prefetchMBytes2 (MBytes mb#) off = prim_ (prefetchMutableByteArray2# mb# (unOffBytes# off)) {-# INLINE prefetchMBytes2 #-} prefetchBytes3 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m () -prefetchBytes3 (Bytes b#) off = prim_ (prefetchByteArray3# b# (fromOff# off)) +prefetchBytes3 (Bytes b#) off = prim_ (prefetchByteArray3# b# (unOffBytes# off)) {-# INLINE prefetchBytes3 #-} prefetchMBytes3 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m () -prefetchMBytes3 (MBytes mb#) off = prim_ (prefetchMutableByteArray3# mb# (fromOff# off)) +prefetchMBytes3 (MBytes mb#) off = prim_ (prefetchMutableByteArray3# mb# (unOffBytes# off)) {-# INLINE prefetchMBytes3 #-} 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 @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} @@ -25,8 +25,13 @@ , isSamePinnedBytes , isPinnedBytes , isPinnedMBytes + , castStateMBytes , castPinnedBytes , castPinnedMBytes + , relaxPinnedBytes + , relaxPinnedMBytes + , toInconclusiveBytes + , toInconclusiveMBytes , allocMBytes , allocPinnedMBytes , allocAlignedMBytes @@ -59,7 +64,8 @@ , withNoHaltPtrMBytes , toForeignPtrBytes , toForeignPtrMBytes - , fromForeignPtrBytes + , castForeignPtrToBytes + , onForeignPtrContents , byteStringConvertError ) where @@ -68,22 +74,26 @@ import Control.Prim.Monad.Unsafe import Data.Prim import Data.Prim.Class -import GHC.ForeignPtr import Data.Typeable import Foreign.Prim - +import GHC.ForeignPtr +import Unsafe.Coerce +#if MIN_VERSION_base(4,14,0) +import Data.IORef +#endif --- | In Haskell there is a distinction between pinned or unpinned memory. +-- | In GHC there is a distinction between pinned and unpinned memory. -- --- Pinned memory is such, when allocated, it is guaranteed not to move throughout the +-- Pinned memory is such that when allocated, it is guaranteed not to move throughout the -- lifetime of a program. In other words the address pointer that refers to allocated --- bytes will not change until it gets garbage collected because it is no longer --- referenced by anything. Unpinned memory on the other hand can be moved around during --- GC, which helps to reduce memory fragmentation. +-- bytes will not change until the associated `ByteArray#` or `MutableByteArray#` is no +-- longer referenced anywhere in the program at which point it gets garbage collected. On +-- the other hand unpinned memory can be moved around during GC, which helps to reduce +-- memory fragmentation. -- -- Pinned/unpinnned choice during allocation is a bit of a lie, because when attempt is -- made to allocate memory as unpinned, but requested size is a bit more than a certain --- threashold (somewhere around 3KiB) it might still be allocated as pinned. Because of +-- threshold (somewhere around 3KiB) it might still be allocated as pinned. Because of -- that fact through out the "primal" universe there is a distinction between memory that -- is either @`Pin`ned@ or @`Inc`onclusive@. -- @@ -91,15 +101,16 @@ -- `Data.Prim.Memory.Bytes.toPinnedMBytes` to get a conclusive type. -- -- @since 0.1.0 -data Pinned = Pin | Inc +data Pinned + = Pin -- ^ Pinned, which indicates that allocated memory will not move + | Inc -- ^ Inconclusive, thus memory could be pinned or unpinned -- | An immutable region of memory which was allocated either as pinned or unpinned. -- -- Constructor is not exported for safety. Violating type level `Pinned` kind is very -- dangerous. Type safe constructor `Data.Prim.Memory.Bytes.fromByteArray#` and unwrapper -- `Data.Prim.Memory.Bytes.toByteArray#` should be used instead. As a backdoor, of course, --- the actual constructor is available in "Data.Prim.Memory.Internal" module and specially --- unsafe function `castPinnedBytes` was crafted. +-- the actual constructor is available from @Data.Prim.Memory.Internal@ data Bytes (p :: Pinned) = Bytes ByteArray# type role Bytes nominal @@ -126,7 +137,7 @@ compareByteOffBytes :: Prim e => Bytes p1 -> Off Word8 -> Bytes p2 -> Off Word8 -> Count e -> Ordering compareByteOffBytes (Bytes b1#) (Off (I# off1#)) (Bytes b2#) (Off (I# off2#)) c = - toOrdering# (compareByteArrays# b1# off1# b2# off2# (fromCount# c)) + toOrdering# (compareByteArrays# b1# off1# b2# off2# (unCountBytes# c)) {-# INLINE compareByteOffBytes #-} indexOffBytes :: Prim e => Bytes p -> Off e -> e @@ -164,7 +175,7 @@ allocUnpinnedMBytes :: (MonadPrim s m, Prim e) => Count e -> m (MBytes 'Inc s) allocUnpinnedMBytes c = prim $ \s -> - case newByteArray# (fromCount# c) s of + case newByteArray# (unCountBytes# c) s of (# s', ba# #) -> (# s', MBytes ba# #) {-# INLINE allocUnpinnedMBytes #-} @@ -172,7 +183,7 @@ allocPinnedMBytes :: (MonadPrim s m, Prim e) => Count e -> m (MBytes 'Pin s) allocPinnedMBytes c = prim $ \s -> - case newPinnedByteArray# (fromCount# c) s of + case newPinnedByteArray# (unCountBytes# c) s of (# s', ba# #) -> (# s', MBytes ba# #) {-# INLINE allocPinnedMBytes #-} @@ -183,7 +194,7 @@ allocAlignedMBytes c = prim $ \s -> case newAlignedPinnedByteArray# - (fromCount# c) + (unCountBytes# c) (alignment# (proxy# :: Proxy# e)) s of (# s', ba# #) -> (# s', MBytes ba# #) @@ -221,13 +232,13 @@ copyByteOffBytesToMBytes :: (MonadPrim s m, Prim e) => Bytes ps -> Off Word8 -> MBytes pd s -> Off Word8 -> Count e -> m () copyByteOffBytesToMBytes (Bytes src#) (Off (I# srcOff#)) (MBytes dst#) (Off (I# dstOff#)) c = - prim_ $ copyByteArray# src# srcOff# dst# dstOff# (fromCount# c) + prim_ $ copyByteArray# src# srcOff# dst# dstOff# (unCountBytes# c) {-# INLINE copyByteOffBytesToMBytes #-} moveByteOffMBytesToMBytes :: (MonadPrim s m, Prim e) => MBytes ps s-> Off Word8 -> MBytes pd s -> Off Word8 -> Count e -> m () moveByteOffMBytesToMBytes (MBytes src#) (Off (I# srcOff#)) (MBytes dst#) (Off (I# dstOff#)) c = - prim_ (copyMutableByteArray# src# srcOff# dst# dstOff# (fromCount# c)) + prim_ (copyMutableByteArray# src# srcOff# dst# dstOff# (unCountBytes# c)) {-# INLINE moveByteOffMBytesToMBytes #-} @@ -239,7 +250,7 @@ -- | 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 `getCountMBytes`. shrinkMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> Count e -> m () -shrinkMBytes (MBytes mb#) c = prim_ (shrinkMutableByteArray# mb# (fromCount# c)) +shrinkMBytes (MBytes mb#) c = prim_ (shrinkMutableByteArray# mb# (unCountBytes# c)) {-# INLINE shrinkMBytes #-} @@ -252,7 +263,7 @@ (MonadPrim s m, Prim e) => MBytes p s -> Count e -> m (MBytes 'Inc s) resizeMBytes (MBytes mb#) c = prim $ \s -> - case resizeMutableByteArray# mb# (fromCount# c) s of + case resizeMutableByteArray# mb# (unCountBytes# c) s of (# s', mb'# #) -> (# s', MBytes mb'# #) {-# INLINE resizeMBytes #-} @@ -274,12 +285,29 @@ Nothing -> castPinnedMBytes <$> resizeMBytes mb newByteCount {-# INLINABLE reallocMBytes #-} +castStateMBytes :: MBytes p s' -> MBytes p s +castStateMBytes = unsafeCoerce + castPinnedBytes :: Bytes p' -> Bytes p castPinnedBytes (Bytes b#) = Bytes b# castPinnedMBytes :: MBytes p' s -> MBytes p s castPinnedMBytes (MBytes b#) = MBytes b# + +relaxPinnedBytes :: Bytes 'Pin -> Bytes p +relaxPinnedBytes = castPinnedBytes + +relaxPinnedMBytes :: MBytes 'Pin e -> MBytes p e +relaxPinnedMBytes = castPinnedMBytes + +toInconclusiveBytes :: Bytes p -> Bytes 'Inc +toInconclusiveBytes = castPinnedBytes + +toInconclusiveMBytes :: MBytes p e -> MBytes 'Inc e +toInconclusiveMBytes = castPinnedMBytes + + -- | How many elements of type @a@ fits into bytes completely. In order to get a possible -- count of leftover bytes use `countRemBytes` countBytes :: Prim e => Bytes p -> Count e @@ -373,26 +401,54 @@ toForeignPtrMBytes :: MBytes 'Pin s -> ForeignPtr e toForeignPtrMBytes (MBytes mba#) = - ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) (PlainPtr (unsafeCoerce# mba#)) + ForeignPtr (mutableByteArrayContents# mba#) (PlainPtr (unsafeCoerce# mba#)) {-# INLINE toForeignPtrMBytes #-} --- | Discarding the `ForeignPtr` will trigger all if there are any associated --- Haskell finalizers. -fromForeignPtrBytes :: ForeignPtr e -> Either String (Bytes 'Pin) -fromForeignPtrBytes (ForeignPtr addr# content) = - case content of - PlainPtr mbaRW# -> checkConvert mbaRW# - MallocPtr mbaRW# _ -> checkConvert mbaRW# - _ -> Left "Cannot convert a C allocated pointer" +-- | This function will only cast a pointer that was allocated on Haskell heap and it is +-- cerain that the ForeignPtr has no finalizers associated with it. +castForeignPtrToBytes :: ForeignPtr e -> Either String (Bytes 'Pin) +castForeignPtrToBytes fp = + unsafePerformIO $ + onForeignPtrContents fp checkConvert $ \_ -> + pure (Left "Cannot convert a C allocated pointer") where - checkConvert mba# = - let !b@(Bytes ba#) = unsafePerformIO (freezeMBytes (MBytes mba#)) - in if isTrue# (byteArrayContents# ba# `eqAddr#` addr#) - then Right b - else Left - "ForeignPtr does not point to the beginning of the associated MutableByteArray#" -{-# INLINE fromForeignPtrBytes #-} + checkConvert addr# mba# checkFinalizers = do + ba@(Bytes ba#) <- freezeMBytes (MBytes mba#) + if isTrue# (byteArrayContents# ba# `eqAddr#` addr#) + then do + hasFinilizers <- checkFinalizers + pure $ + if hasFinilizers + then Left "MallocPtr has associated finalizers" + else Right ba + else pure $ + Left + "ForeignPtr does not point to the beginning of the associated MutableByteArray#" +{-# INLINE castForeignPtrToBytes #-} + + +onForeignPtrContents :: + MonadPrim RW m + => ForeignPtr e + -> (Addr# -> MutableByteArray# RW -> m Bool -> m a) + -> (Addr# -> m a) + -> m a +onForeignPtrContents (ForeignPtr addr# contents) onHaskellPtr onCPtr = + case contents of + PlainPtr mbaRW# -> onHaskellPtr addr# mbaRW# (pure False) +#if MIN_VERSION_base(4,14,0) + MallocPtr mbaRW# fref -> onHaskellPtr addr# mbaRW# $ do + finilizers <- liftPrimBase $ readIORef fref + pure $! case finilizers of + NoFinalizers -> False + HaskellFinalizers fs -> not $! null fs + CFinalizers _ -> True -- impossible case, but nevertheless +#else + MallocPtr mbaRW# _ -> onHaskellPtr addr# mbaRW# (pure True) +#endif + PlainForeignPtr _ -> onCPtr addr# +{-# INLINE onForeignPtrContents #-} -- | Check if two byte arrays refer to pinned memory and compare their pointers. 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 @@ -2,9 +2,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Prim.Bytes.ForeignPtr -- Copyright : (c) Alexey Kuleshevich 2020 @@ -60,31 +60,19 @@ , toForeignPtrMBytes ) where -import Control.Prim.Monad -import Data.Prim -import Data.Prim.Class -import Data.Prim.Memory.ByteString -import Data.Prim.Memory.Bytes.Internal - ( Bytes - , MBytes(..) - , Pinned(..) - , toForeignPtrBytes - , toForeignPtrMBytes - , withNoHaltPtrBytes - , withNoHaltPtrMBytes - , withPtrBytes - , withPtrMBytes - ) -import Foreign.Prim -import GHC.ForeignPtr - ( FinalizerEnvPtr - , FinalizerPtr - , ForeignPtr(..) - , ForeignPtrContents(..) - , castForeignPtr - , unsafeForeignPtrToPtr - ) +import Control.Prim.Monad +import Data.Prim +import Data.Prim.Class +import Data.Prim.Memory.Bytes.Internal (Bytes, MBytes(..), Pinned(..), + toForeignPtrBytes, toForeignPtrMBytes, + withNoHaltPtrBytes, withNoHaltPtrMBytes, + withPtrBytes, withPtrMBytes) +import Data.Prim.Memory.ByteString import qualified Foreign.ForeignPtr as GHC +import Foreign.Prim +import GHC.ForeignPtr (FinalizerEnvPtr, FinalizerPtr, ForeignPtr(..), + ForeignPtrContents(..), castForeignPtr, + unsafeForeignPtrToPtr) import qualified GHC.ForeignPtr as GHC @@ -102,19 +90,17 @@ withPtrAccess p action = toForeignPtr p >>= (`withForeignPtr` action) {-# INLINE withPtrAccess #-} - -- | See this GHC and - -- related to get more insight why this is needed. - withNoHaltPtrAccess :: (MonadUnliftPrim s m) => p -> (Ptr a -> m b) -> m b - withNoHaltPtrAccess p f = do - ForeignPtr addr# ptrContents <- toForeignPtr p - withAliveUnliftPrim ptrContents $ f (Ptr addr#) + -- | See this GHC and + -- related to it in order to get more insight why this is needed. + withNoHaltPtrAccess :: MonadUnliftPrim s m => p -> (Ptr a -> m b) -> m b + withNoHaltPtrAccess p action = toForeignPtr p >>= (`withNoHaltForeignPtr` action) {-# INLINE withNoHaltPtrAccess #-} instance PtrAccess s (ForeignPtr a) where toForeignPtr = pure . coerce {-# INLINE toForeignPtr #-} --- | Read-only access, but it is not enforced. +-- | Read-only access, but immutability is not enforced. instance PtrAccess s ByteString where toForeignPtr (PS ps s _) = pure (coerce ps `plusByteOffForeignPtr` Off s) {-# INLINE toForeignPtr #-} @@ -131,7 +117,7 @@ withNoHaltPtrAccess mbs = withNoHaltPtrByteString (coerce mbs) {-# INLINE withNoHaltPtrAccess #-} --- | Read-only access, but it is not enforced. +-- | Read-only access, but immutability is not enforced. instance PtrAccess s (Bytes 'Pin) where toForeignPtr = pure . toForeignPtrBytes {-# INLINE toForeignPtr #-} @@ -198,7 +184,7 @@ -- | Similar to `Foreign.ForeignPtr.mallocForeignPtrArray`, except instead of `Storable` we -- use `Prim`. mallocCountForeignPtr :: (MonadPrim RW m, Prim e) => Count e -> m (ForeignPtr e) -mallocCountForeignPtr = liftPrimBase . GHC.mallocForeignPtrBytes . fromCount +mallocCountForeignPtr = liftPrimBase . GHC.mallocForeignPtrBytes . unCountBytes -- | Just like `mallocCountForeignPtr`, but memory is also aligned according to `Prim` instance mallocCountForeignPtrAligned :: (MonadPrim RW m, Prim e) => Count e -> m (ForeignPtr e) @@ -252,7 +238,7 @@ mallocCountPlainForeignPtrAligned c = prim $ \s -> let a# = alignment# (proxy# :: Proxy# e) - in case newAlignedPinnedByteArray# (fromCount# c) a# s of + in case newAlignedPinnedByteArray# (unCountBytes# c) a# s of (# s', mba# #) -> let addr# = mutableByteArrayContents# mba# in (# s', ForeignPtr addr# (PlainPtr (unsafeCoerce# mba#)) #) @@ -304,7 +290,7 @@ -- @since 0.1.0 plusOffForeignPtr :: Prim e => ForeignPtr e -> Off e -> ForeignPtr e plusOffForeignPtr (ForeignPtr addr# content) off = - ForeignPtr (addr# `plusAddr#` fromOff# off) content + ForeignPtr (addr# `plusAddr#` unOffBytes# off) content {-# INLINE plusOffForeignPtr #-} 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 @@ -2,979 +2,2356 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Data.Prim.Memory.Internal --- Copyright : (c) Alexey Kuleshevich 2020 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Data.Prim.Memory.Internal - ( Bytes(..) - , MBytes(..) - , Pinned(..) - , module Data.Prim.Memory.Internal - ) where - -import Control.Exception -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Monad.ST -import Control.Prim.Monad -import Control.Prim.Monad.Unsafe -import Data.Foldable as Foldable -import Data.Prim -import Data.Prim.Memory.Bytes.Internal - ( Bytes(..) - , MBytes(..) - , Pinned(..) - , allocMBytes - , reallocMBytes - , byteCountBytes - , compareByteOffBytes - , copyByteOffBytesToMBytes - , freezeMBytes - , getByteCountMBytes - , indexByteOffBytes - , indexOffBytes - , isSameBytes - , moveByteOffMBytesToMBytes - , readByteOffMBytes - , readOffMBytes - , setMBytes - , thawBytes - , writeByteOffMBytes - , writeOffMBytes - ) -import Data.List as List -import Data.Prim.Memory.ByteString -import Data.Prim.Memory.ForeignPtr -import Data.Prim.Memory.Ptr -import Foreign.Prim -import Numeric (showHex) -import qualified Data.Semigroup as Semigroup -import qualified Data.Monoid as Monoid -import Data.Kind - - -class MemRead r where - byteCountMem :: r -> Count Word8 - - indexOffMem :: Prim e => r -> Off e -> e - - indexByteOffMem :: Prim e => r -> Off Word8 -> e - - -- | Source and target can't refer to the same memory chunks - copyByteOffToMBytesMem :: - (MonadPrim s m, Prim e) => r -> Off Word8 -> MBytes p s -> Off Word8 -> Count e -> m () - - -- | Source and target can't refer to the same memory chunks - copyByteOffToPtrMem :: - (MonadPrim s m, Prim e) => r -> Off Word8 -> Ptr e -> Off Word8 -> Count e -> m () - - compareByteOffToPtrMem :: - (MonadPrim s m, Prim e) => r -> Off Word8 -> Ptr e -> Off Word8 -> Count e -> m Ordering - - compareByteOffToBytesMem :: - (MonadPrim s m, Prim e) => r -> Off Word8 -> Bytes p -> Off Word8 -> Count e -> m Ordering - - compareByteOffMem :: - (MemRead r', Prim e) => r' -> Off Word8 -> r -> Off Word8 -> Count e -> Ordering - --- | Generalized memory allocation and pure/mutable state conversion. -class (MemRead (FrozenMem a), MemWrite a) => MemAlloc a where - type FrozenMem a = (fa :: Type) | fa -> a - - getByteCountMem :: MonadPrim s m => a s -> m (Count Word8) - - allocByteCountMem :: MonadPrim s m => Count Word8 -> m (a s) - - thawMem :: MonadPrim s m => FrozenMem a -> m (a s) - - freezeMem :: MonadPrim s m => a s -> m (FrozenMem a) - - resizeMem :: (MonadPrim s m, Prim e) => a s -> Count e -> m (a s) - resizeMem = defaultResizeMem - - -class MemWrite w where - readOffMem :: (MonadPrim s m, Prim e) => w s -> Off e -> m e - - readByteOffMem :: (MonadPrim s m, Prim e) => w s -> Off Word8 -> m e - - writeOffMem :: (MonadPrim s m, Prim e) => w s -> Off e -> e -> m () - - writeByteOffMem :: (MonadPrim s m, Prim e) => w s -> Off Word8 -> e -> m () - - -- | Source and target can be overlapping memory chunks - moveByteOffToMBytesMem :: - (MonadPrim s m, Prim e) => w s -> Off Word8 -> MBytes p s -> Off Word8 -> Count e -> m () - - -- | Source and target can be overlapping memory chunks - moveByteOffToPtrMem :: - (MonadPrim s m, Prim e) => w s -> Off Word8 -> Ptr e -> Off Word8 -> Count e -> m () - - copyByteOffMem :: - (MonadPrim s m, MemRead r, Prim e) => r -> Off Word8 -> w s -> Off Word8 -> Count e -> m () - - moveByteOffMem :: - (MonadPrim s m, MemWrite w', Prim e) => w' s -> Off Word8 -> w s -> Off Word8 -> Count 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 into each cell starting at an offset. - setMem - :: (MonadPrim s m, Prim e) - => w s -- ^ Writable memory. Must have enough bytes, at least: (off+count)*(sizeOf e) - -> Off e -- ^ An offset into writable memory at which element setting should start. - -> Count e -- ^ Numer of cells to write the elemnt into - -> e -- ^ Element to write into all memory cells specified by offset and count. Even - -- if the count is @0@ this element might be still fully evaluated. - -> m () - - -instance MemRead ByteString where - byteCountMem (PS _ _ c) = Count c - {-# 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 = - 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 (PS _ _ c)) = pure $ Count c - {-# INLINE getByteCountMem #-} - allocByteCountMem c = do - fp <- mallocByteCountPlainForeignPtr c - pure $ MByteString (PS fp 0 (coerce c)) - {-# INLINE allocByteCountMem #-} - 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 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 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 use 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 w, MonadPrim s m, Prim b) => w s -> Off b -> (b -> b) -> m b -modifyFetchOldMem mem o f = modifyFetchOldMemM mem o (pure . f) -{-# INLINE modifyFetchOldMem #-} - - -modifyFetchNewMem :: - (MemWrite w, MonadPrim s m, Prim b) => w s -> Off b -> (b -> b) -> m b -modifyFetchNewMem mem o f = modifyFetchNewMemM mem o (pure . f) -{-# INLINE modifyFetchNewMem #-} - - -modifyFetchOldMemM :: - (MemWrite w, MonadPrim s m, Prim b) => w s -> Off b -> (b -> m b) -> m b -modifyFetchOldMemM mem o f = do - a <- readOffMem mem o - a <$ (writeOffMem mem o =<< f a) -{-# INLINE modifyFetchOldMemM #-} - - -modifyFetchNewMemM :: - (MemWrite w, MonadPrim s m, Prim b) => w s -> Off b -> (b -> m b) -> m b -modifyFetchNewMemM mem o f = do - a <- readOffMem mem o - a' <- f a - a' <$ writeOffMem mem o a' -{-# INLINE modifyFetchNewMemM #-} - - -defaultResizeMem :: - (Prim e, MemAlloc a, MonadPrim s m) => a s -> Count e -> m (a s) -defaultResizeMem mem c = do - let newByteCount = toByteCount c - oldByteCount <- getByteCountMem mem - if oldByteCount == newByteCount - then pure mem - else do - newMem <- allocByteCountMem newByteCount - newMem <$ moveMem mem 0 newMem 0 oldByteCount - - --- | Make @n@ copies of supplied region of memory into a contiguous chunk of memory. -cycleMemN :: (MemAlloc a, MemRead r) => Int -> r -> FrozenMem a -cycleMemN n r - | n <= 0 = emptyMem - | otherwise = - runST $ do - let bc@(Count chunk) = byteCountMem r - c@(Count c8) = Count n * bc - mem <- allocByteCountMem c - let go i = when (i < c8) $ copyByteOffMem r 0 mem (Off i) bc >> go (i + chunk) - go 0 - freezeMem mem -{-# INLINE cycleMemN #-} - - --- | Chunk of empty memory. -emptyMem :: MemAlloc a => FrozenMem a -emptyMem = createMemST_ (0 :: Count Word8) (\_ -> pure ()) -{-# INLINE emptyMem #-} - --- | A region of memory that hold a single element. -singletonMem :: - forall e a. (MemAlloc a, Prim e) - => e - -> FrozenMem a -singletonMem a = createMemST_ (1 :: Count e) $ \mem -> writeOffMem mem 0 a -{-# INLINE singletonMem #-} - --- | Allocate enough memory for number of elements. Memory is not initialized and may --- contain garbage. Use `allocZeroMem` if clean memory is needed. --- --- [Unsafe Count] Negative element count will result in unpredictable behavior --- --- @since 0.1.0 -allocMem :: (MemAlloc a, MonadPrim s m, Prim e) => Count e -> m (a s) -allocMem n = allocByteCountMem (toByteCount n) -{-# INLINE allocMem #-} - - --- | Same as `allocMem`, but also use @memset@ to initialize all the new memory to zeros. --- --- [Unsafe Count] Negative element count will result in unpredictable behavior --- --- @since 0.1.0 -allocZeroMem :: - (MemAlloc a, MonadPrim s m, Prim e) => Count e -> m (a s) -allocZeroMem n = do - m <- allocMem n - m <$ setMem m 0 (toByteCount n) (0 :: Word8) -{-# INLINE allocZeroMem #-} - - -createMemST :: (MemAlloc a, Prim e) => Count e -> (forall s . a s -> ST s b) -> (b, FrozenMem a) -createMemST n f = runST $ do - m <- allocMem n - res <- f m - i <- freezeMem m - pure (res, i) -{-# INLINE createMemST #-} - -createMemST_ :: (MemAlloc a, Prim e) => Count e -> (forall s . a s -> ST s b) -> FrozenMem a -createMemST_ n f = runST (allocMem n >>= \m -> f m >> freezeMem m) -{-# INLINE createMemST_ #-} - -createZeroMemST :: (MemAlloc a, Prim e) => Count e -> (forall s . a s -> ST s b) -> (b, FrozenMem a) -createZeroMemST n f = runST $ do - m <- allocZeroMem n - res <- f m - i <- freezeMem m - pure (res, i) -{-# INLINE createZeroMemST #-} - -createZeroMemST_ :: (MemAlloc a, Prim e) => Count e -> (forall s . a s -> ST s b) -> FrozenMem a -createZeroMemST_ n f = runST (allocZeroMem n >>= \m -> f m >> freezeMem m) -{-# INLINE createZeroMemST_ #-} - - -copyMem :: - (MonadPrim s m, MemRead r, MemWrite w, Prim e) - => r -- ^ Source memory region - -> Off e -- ^ Offset into the source in number of elements - -> w s -- ^ Destination memory region - -> Off e -- ^ Offset into destination in number of elements - -> Count e -- ^ Number of elements to copy over - -> m () -copyMem src srcOff dst dstOff = copyByteOffMem src (toByteOff srcOff) dst (toByteOff dstOff) -{-# INLINE copyMem #-} - - -moveMem :: - (MonadPrim s m, MemWrite w1, MemWrite w2, Prim e) - => w1 s -- ^ Source memory region - -> Off e -- ^ Offset into the source in number of elements - -> w2 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 :: (MemRead r1, MemRead r2, MemAlloc a) => r1 -> r2 -> FrozenMem a -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 :: (MemRead r, MemAlloc a) => [r] -> FrozenMem a -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 :: - (MemRead r, MemAlloc a, MonadPrim s m, Prim e) => r -> Off e -> Count e -> m (a s) -thawCopyMem a off c = do - mem <- allocMem c - mem <$ copyMem a off mem 0 c -{-# INLINE thawCopyMem #-} - -freezeCopyMem :: - (MemAlloc a, MonadPrim s m, Prim e) - => a s - -> Off e - -> Count e - -> m (FrozenMem a) -freezeCopyMem mem off c = freezeMem mem >>= \r -> thawCopyMem r off c >>= freezeMem -{-# INLINE freezeCopyMem #-} - - -thawCloneMem :: (MemRead r, MemAlloc a, MonadPrim s m) => r -> m (a s) -thawCloneMem a = thawCopyMem a 0 (byteCountMem a) -{-# INLINE thawCloneMem #-} - -freezeCloneMem :: (MemAlloc a, MonadPrim s m) => a s -> m (FrozenMem a) -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 --- >>> 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 r, MemAlloc a) => r -> FrozenMem a -convertMem a = runST $ thawCloneMem a >>= freezeMem -{-# INLINE convertMem #-} - --- | Figure out how many elements can fit into the 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 r. (MemRead r, Prim e) - => r -- ^ Read-only memory type - -> 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},0) --- >>> countRemMem @Word32 b --- (Count {unCount = 1},2) --- --- @since 0.1.0 -countRemMem :: forall e r. (MemRead r, Prim e) => r -> (Count e, Count Word8) -countRemMem = fromByteCountRem . byteCountMem -{-# INLINE countRemMem #-} - -getCountMem :: (MemAlloc r, MonadPrim s m, Prim e) => r s -> m (Count e) -getCountMem = fmap (fromByteCount . coerce) . getByteCountMem -{-# INLINE getCountMem #-} - - -getCountRemMem :: (MemAlloc r, MonadPrim s m, Prim e) => r s -> m (Count e, Count Word8) -getCountRemMem = fmap (fromByteCountRem . coerce) . getByteCountMem -{-# INLINE getCountRemMem #-} - - -clone :: (MemAlloc r, MonadPrim s m) => r s -> m (r s) -clone mb = do - n <- getByteCountMem mb - mb' <- allocMem n - mb' <$ moveMem mb 0 mb' 0 n -{-# INLINE clone #-} - -eqMem :: (MemRead r1, MemRead r2) => r1 -> r2 -> 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 :: - (MemRead r1, MemRead r2, Prim e) - => r1 -- ^ First region of memory - -> Off e -- ^ Offset in number of elements into the first region - -> r2 -- ^ 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 #-} - --- | It is only guaranteed to convert the whole memory to a list whenever the size of --- allocated memory is exactly divisible by the size of the element, otherwise there will --- be some slack left unaccounted for. -toListMem :: (MemRead r, Prim e) => r -> [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 if there is some slack at the end of the memory that --- didn't fit in 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 r. (MemRead r, Prim e) - => r - -> ([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 list while tapping into list fusion. -foldrCountMem :: (MemRead r, Prim e) => Count e -> (e -> b -> b) -> b -> r -> 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 #-} - - -loadListMemN :: - (MemWrite r, MonadPrim s m, Prim e) - => Count e - -> Count Word8 - -> [e] - -> r s - -> m Ordering -loadListMemN (Count n) (Count slack) ys mb = do - let go [] !i = pure (compare i n <> compare 0 slack) - go (x:xs) !i - | i < n = writeOffMem mb (Off i) x >> go xs (i + 1) - | otherwise = pure GT - go ys 0 -{-# INLINABLE loadListMemN #-} - -loadListMemN_ :: (MemWrite r, MonadPrim s m, Prim e) => Count e -> [e] -> r s -> 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_ #-} - --- | Returns `EQ` if the full list did fit into the supplied memory chunk exactly. --- Otherwise it will return either `LT` if the list was smaller than allocated memory or --- `GT` if the list was bigger than the available memory and did not fit into `MBytes`. -loadListMem :: (MonadPrim s m, MemAlloc r, Prim e) => [e] -> r s -> m Ordering -loadListMem ys mb = do - (c, slack) <- getCountRemMem mb - loadListMemN (countAsProxy ys c) slack ys mb -{-# INLINE loadListMem #-} - -loadListMem_ :: (MonadPrim s m, MemAlloc r, Prim e) => [e] -> r s -> m () -loadListMem_ ys mb = do - c <- getCountMem mb - loadListMemN_ (countAsProxy ys c) ys mb -{-# INLINE loadListMem_ #-} - - -fromListMemN :: (MemAlloc a, Prim e) => Count e -> [e] -> (Ordering, FrozenMem a) -fromListMemN n xs = createMemST n (loadListMemN n 0 xs) -{-# INLINE fromListMemN #-} - -fromListMemN_ :: (MemAlloc a, Prim e) => Count e -> [e] -> FrozenMem a -fromListMemN_ !n xs = createMemST_ n (loadListMemN_ n xs) -{-# INLINE fromListMemN_ #-} - -fromListMem :: (MemAlloc a, Prim e) => [e] -> FrozenMem a -fromListMem xs = fromListMemN_ (countAsProxy xs (coerce (length xs))) xs -{-# INLINE fromListMem #-} - - --- | 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 :: MemAlloc a => [Word8] -> FrozenMem a -fromByteListMem = fromListMem -{-# INLINE fromByteListMem #-} - --- | Convert a memory region to a list of bytes. Equivalent to `Data.ByteString.unpack` --- for `Data.ByteString.ByteString` --- --- >>> toByteListMem (fromByteListMem [0..10] :: Bytes 'Pin) --- [0,1,2,3,4,5,6,7,8,9,10] --- --- @since 0.1.0 -toByteListMem :: MemAlloc a => FrozenMem a -> [Word8] -toByteListMem = toListMem -{-# INLINE toByteListMem #-} - - -mapByteMem :: (MemRead r, MemAlloc a, Prim e) => (Word8 -> e) -> r -> FrozenMem a -mapByteMem f = mapByteOffMem (const f) - --- | Map an index aware function over memory region --- --- >>> a = fromListMem [1 .. 10 :: Word8] :: Bytes 'Inc --- >>> a --- [0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a] --- >>> imapMem (\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 -mapByteOffMem :: - (MemRead r, MemAlloc a, Prim e) => (Off Word8 -> Word8 -> e) -> r -> FrozenMem a -mapByteOffMem f r = runST $ mapByteOffMemM (\i -> pure . f i) r - --- @since 0.1.0 -mapByteMemM :: - (MemRead r, MemAlloc a, MonadPrim s m, Prim e) - => (Word8 -> m e) - -> r - -> m (FrozenMem a) -mapByteMemM f = mapByteOffMemM (const f) - - --- @since 0.1.0 -mapByteOffMemM :: - (MemRead r, MemAlloc a, MonadPrim s m, Prim e) - => (Off Word8 -> Word8 -> m e) - -> r - -> m (FrozenMem a) -mapByteOffMemM f r = do - let bc@(Count n) = byteCountMem r - c = countAsProxy (f 0 0) (Count n) - 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 r, MonadPrim s m, Prim e) - => r - -> 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 r, 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 r1, MemRead r2, MonadPrim s m, Prim e) - => r1 - -> Off Word8 - -> r2 - -> 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 r1, MemRead r2, MonadPrim s m, Prim e1, Prim e2) - => r1 - -> Off e1 - -> r2 - -> 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 orphans -- -------------------- - -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 = - pure $ compareByteOffBytes bytes1 off1 bytes2 off2 c - {-# INLINE compareByteOffToBytesMem #-} - compareByteOffMem mem1 off1 bs off2 c = - unsafeInlineIO $ 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 #-} - allocByteCountMem = allocMBytes - {-# INLINE allocByteCountMem #-} - 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 - fromListN n = fromListMemN_ (Count n) - toList = toListMem - -instance Eq (Bytes p) where - b1 == b2 = isSameBytes b1 b2 || eqMem b1 b2 - -instance Ord (Bytes p) where - compare b1 b2 = - compare n (byteCountBytes b2) <> compareByteOffBytes b1 0 b2 0 n - where - n = byteCountBytes b1 - -instance Typeable p => Semigroup.Semigroup (Bytes p) where - (<>) = appendMem - sconcat (x :| xs) = concatMem (x:xs) - stimes i = cycleMemN (fromIntegral i) - -instance Typeable p => Monoid.Monoid (Bytes p) where - mappend = appendMem - mconcat = concatMem - mempty = emptyMem - - --- | A list of `ShowS` that covert bytes to base16 encoded strings. Each element of the list --- is a function that will convert one byte. --- --- >>> mb <- newPinnedMBytes (Count 5 :: Count Int) --- >>> mapM_ (\i -> writeOffMBytes mb (pred i) i) [1 .. 5] --- >>> foldr ($) "" . showsBytesHex <$> freezeMBytes mb --- "01000000000000000200000000000000030000000000000004000000000000000500000000000000" --- -showsHexMem :: MemRead r => r -> [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 is used. -withScrubbedMem :: - (MonadUnliftPrim RW m, Prim e, MemAlloc mem) - => Count e - -> (mem RW -> m a) - -> m a -withScrubbedMem c f = do - mem <- allocZeroMem c - f mem `finallyPrim` setMem mem 0 (toByteCount c) 0 - where - finallyPrim m1 m2 = withRunInPrimBase $ \run -> finally (run m1) (run m2) +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide, not-home #-} +-- | +-- Module : Data.Prim.Memory.Internal +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Memory.Internal + ( module Data.Prim.Memory.Internal + , 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 #-} diff --git a/src/Data/Prim/Memory/PrimArray.hs b/src/Data/Prim/Memory/PrimArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/PrimArray.hs @@ -0,0 +1,310 @@ +{-# 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/Ptr.hs b/src/Data/Prim/Memory/Ptr.hs --- a/src/Data/Prim/Memory/Ptr.hs +++ b/src/Data/Prim/Memory/Ptr.hs @@ -55,7 +55,7 @@ copyByteOffPtrToMBytes :: (MonadPrim s m, Prim e) => Ptr e -> Off Word8 -> MBytes p s -> Off Word8 -> Count e -> m () copyByteOffPtrToMBytes (Ptr srcAddr#) (Off (I# srcOff#)) (MBytes dst#) (Off (I# dstOff#)) c = - prim_ $ copyAddrToByteArray# (srcAddr# `plusAddr#` srcOff#) dst# dstOff# (fromCount# c) + prim_ $ copyAddrToByteArray# (srcAddr# `plusAddr#` srcOff#) dst# dstOff# (unCountBytes# c) {-# INLINE copyByteOffPtrToMBytes #-} @@ -79,7 +79,7 @@ src# srcOff# (dstAddr# `plusAddr#` dstOff#) - (fromCount# c) + (unCountBytes# c) {-# INLINE copyByteOffBytesToPtr #-} @@ -103,7 +103,7 @@ src# srcOff# (dstAddr# `plusAddr#` dstOff#) - (fromCount# c) + (unCountBytes# c) {-# INLINE copyByteOffMBytesToPtr #-} @@ -122,7 +122,7 @@ -> m () moveByteOffPtrToMBytes (Ptr srcAddr#) (Off (I# srcOff#)) (MBytes dst#) (Off (I# dstOff#)) c = unsafeIOToPrim $ - memmoveMutableByteArrayFromAddr# srcAddr# srcOff# dst# dstOff# (fromCount# c) + memmoveMutableByteArrayFromAddr# srcAddr# srcOff# dst# dstOff# (unCountBytes# c) {-# INLINE moveByteOffPtrToMBytes #-} moveMBytesToPtr :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> Ptr e -> Off e -> Count e -> m () @@ -135,18 +135,18 @@ (MonadPrim s m, Prim e) => MBytes p s -> Off Word8 -> Ptr e -> Off Word8 -> Count e -> m () moveByteOffMBytesToPtr (MBytes src#) (Off (I# srcOff#)) (Ptr dstAddr#) (Off (I# dstOff#)) c = unsafeIOToPrim $ - memmoveMutableByteArrayToAddr# src# srcOff# dstAddr# dstOff# (fromCount# c) + memmoveMutableByteArrayToAddr# src# srcOff# dstAddr# dstOff# (unCountBytes# c) {-# INLINE moveByteOffMBytesToPtr #-} compareByteOffBytesToPtr :: Prim e => Bytes p -> Off Word8 -> Ptr e -> Off Word8 -> Count e -> Ordering compareByteOffBytesToPtr (Bytes b#) (Off (I# off1#)) (Ptr addr#) (Off (I# off2#)) c = - toOrdering# (memcmpByteArrayAddr# b# off1# addr# off2# (fromCount# c)) + toOrdering# (memcmpByteArrayAddr# b# off1# addr# off2# (unCountBytes# c)) {-# INLINE compareByteOffBytesToPtr #-} compareByteOffPtrToBytes :: Prim e => Ptr e -> Off Word8 -> Bytes p -> Off Word8 -> Count e -> Ordering compareByteOffPtrToBytes (Ptr addr#) (Off (I# off1#)) (Bytes b#) (Off (I# off2#)) c = - toOrdering# (memcmpAddrByteArray# addr# off1# b# off2# (fromCount# c)) + toOrdering# (memcmpAddrByteArray# addr# off1# b# off2# (unCountBytes# c)) {-# INLINE compareByteOffPtrToBytes #-} diff --git a/src/Data/Prim/Memory/Text.hs b/src/Data/Prim/Memory/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Text.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.Prim.Memory.Text +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Memory.Text + ( Text(..) + , MText(..) + , Array(..) + , MArray(..) + , toBytesArray + , fromBytesArray + , toMBytesMArray + , fromMBytesMArray + ) where + +import Data.Text.Array +import Data.Text.Internal +import Data.Prim.Memory.Bytes.Internal + ( Bytes(..) + , MBytes(..) + , Pinned(..) + ) + +-- | Mutable version of a `Text` +data MText s = + MText + {-# UNPACK #-}!(MArray s) -- payload (Word16 elements) + {-# 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 #-} + +fromBytesArray :: Bytes p -> Array +fromBytesArray (Bytes ba#) = Array ba# +{-# INLINE fromBytesArray #-} + +toMBytesMArray :: MArray s -> MBytes 'Inc s +toMBytesMArray (MArray mba#) = MBytes mba# +{-# INLINE toMBytesMArray #-} + +fromMBytesMArray :: MBytes p s -> MArray s +fromMBytesMArray (MBytes ba#) = MArray ba# +{-# INLINE fromMBytesMArray #-} + + diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src", "-fobject-code"]