primal-memory (empty) → 0.1.0.0
raw patch · 16 files changed
+4878/−0 lines, 16 filesdep +basedep +bytestringdep +criterionsetup-changed
Dependencies added: base, bytestring, criterion, deepseq, primal, primal-memory, primitive, random
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +6/−0
- bench/Bench.hs +177/−0
- bench/Conversion.hs +151/−0
- primal-memory.cabal +92/−0
- src/Data/Prim/Memory.hs +89/−0
- src/Data/Prim/Memory/Addr.hs +1058/−0
- src/Data/Prim/Memory/ByteArray.hs +311/−0
- src/Data/Prim/Memory/ByteString.hs +123/−0
- src/Data/Prim/Memory/Bytes.hs +939/−0
- src/Data/Prim/Memory/Bytes/Internal.hs +416/−0
- src/Data/Prim/Memory/ForeignPtr.hs +345/−0
- src/Data/Prim/Memory/Internal.hs +980/−0
- src/Data/Prim/Memory/Ptr.hs +152/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for primal-memory++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexey Kuleshevich (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alexey Kuleshevich nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+# primal-memory+++* Bridge the gap between `Storable` and `Prim`.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import GHC.Exts+import Data.Proxy+import Data.Typeable+import Criterion.Main+import Data.Prim.Memory.Bytes+import Data.Prim.Memory.Ptr+import Control.Prim.Monad+import qualified Data.Primitive.Types as BA+import qualified Data.Primitive.ByteArray as BA+import qualified Control.Monad.Primitive as BA+import Foreign.Storable as S++main :: IO ()+main = do+ let n = 1000000 :: Count a+ n64 = n :: Count Word64+ mb1 <- allocAlignedMBytes n64+ mb2 <- allocAlignedMBytes n64+ b1 <- freezeMBytes mb1+ mba <- BA.newAlignedPinnedByteArray (fromCount (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+ BA.setByteArray mbaEq1 0 (unCount n64) (0 :: Word64)+ BA.setByteArray mbaEq2 0 (unCount n64) (0 :: Word64)+ defaultMain+ [ bgroup+ "ptr"+ [ env (freezeMBytes mb1) $ \b ->+ bench "(==) - isSameBytes" $ whnf (isSameBytes b) b+ , env (freezeMBytes mb1) $ \b ->+ bench "isSameBytes" $ whnf (isSameBytes b) (relaxPinnedBytes b)+ , env (freezeMBytes mb1) $ \b ->+ bench "isSamePinnedBytes" $ whnf (isSamePinnedBytes b) b+ , bench "(==) - sameByteArray (unexported)" $ whnf (ba ==) ba+ , bench "isSameMBytes" $ whnf (isSameMBytes mb1) mb1+ , bench "sameMutableByteArray" $ whnf (BA.sameMutableByteArray mba) mba+ ]+ , bgroup+ "set"+ [ bgroup+ "0"+ [ setBytesBench mb1 mb2 mba 0 (n * 8 :: Count Word8)+ , setBytesBench mb1 mb2 mba 0 (n * 4 :: Count Word16)+ , setBytesBench mb1 mb2 mba 0 (n * 2 :: Count Word32)+ , setBytesBench mb1 mb2 mba 0 (n :: Count Word64)+ , setBytesBench mb1 mb2 mba 0 (n * 2 :: Count Float)+ , setBytesBench mb1 mb2 mba 0 (n :: Count Double)+ , bench "setMBytes/Bool" $+ nfIO (setMBytes mb1 0 (n * 8 :: Count Bool) False)+ ]+ , bgroup+ "regular"+ [ setBytesBench mb1 mb2 mba 123 (n * 8 :: Count Word8)+ , setBytesBench mb1 mb2 mba 123 (n * 4 :: Count Word16)+ , setBytesBench mb1 mb2 mba 123 (n * 2 :: Count Word32)+ , setBytesBench mb1 mb2 mba 123 (n :: Count Word64)+ , setBytesBench mb1 mb2 mba 123 (n * 2 :: Count Float)+ , setBytesBench mb1 mb2 mba 123 (n :: Count Double)+ , bench "setMBytes/Bool" $+ nfIO (setMBytes mb1 0 (n * 8 :: Count Bool) True)+ ]+ , bgroup+ "symmetric"+ [ setBytesBench mb1 mb2 mba maxBound (n * 8 :: Count Word8)+ , setBytesBench mb1 mb2 mba maxBound (n * 4 :: Count Word16)+ , setBytesBench mb1 mb2 mba maxBound (n * 2 :: Count Word32)+ , setBytesBench mb1 mb2 mba maxBound (n :: Count Word64)+ ]+ ]+ , bgroup+ "access"+ [ bgroup+ "index"+ [ benchIndex (Proxy :: Proxy Word8) b1 ba+ , benchIndex (Proxy :: Proxy Word16) b1 ba+ , benchIndex (Proxy :: Proxy Word32) b1 ba+ , benchIndex (Proxy :: Proxy Word64) b1 ba+ , benchIndex (Proxy :: Proxy Char) b1 ba+ , bgroup+ "Bool"+ [bench "Bytes" $ whnf (indexOffBytes b1) (Off 125 :: Off Bool)]+ ]+ , bgroup+ "read"+ [ benchRead (Proxy :: Proxy Word8) mb1 mba+ , benchRead (Proxy :: Proxy Word16) mb1 mba+ , benchRead (Proxy :: Proxy Word32) mb1 mba+ , benchRead (Proxy :: Proxy Word64) mb1 mba+ , benchRead (Proxy :: Proxy Char) mb1 mba+ , bgroup+ "Bool" -- TODO: try out FFI+ [bench "Bytes" $ whnfIO (readOffMBytes mb1 (Off 125 :: Off Bool))]+ ]+ , bgroup+ "peek"+ [ benchPeek (Proxy :: Proxy Word8) mb1 mba+ , benchPeek (Proxy :: Proxy Word16) mb1 mba+ , benchPeek (Proxy :: Proxy Word32) mb1 mba+ , benchPeek (Proxy :: Proxy Word64) mb1 mba+ , benchPeek (Proxy :: Proxy Char) mb1 mba+ , bgroup+ "Bool"+ [ bench "Bytes" $+ whnfIO (withPtrMBytes mb1 (readPtr :: Ptr Bool -> IO Bool))+ ]+ ]+ ]+ ]++benchIndex ::+ forall a p. (Typeable a, Prim a, BA.Prim a)+ => Proxy a+ -> Bytes p+ -> BA.ByteArray+ -> Benchmark+benchIndex px b ba =+ bgroup+ (showsType px "")+ [ bench "Bytes" $ whnf (indexOffBytes b) (Off i :: Off a)+ , bench "ByteArray" $ whnf (BA.indexByteArray ba :: Int -> a) i+ ]+ where i = 100++benchRead ::+ forall a p. (Typeable a, Prim a, BA.Prim a)+ => Proxy a+ -> MBytes p RealWorld+ -> BA.MutableByteArray RealWorld+ -> Benchmark+benchRead px mb mba =+ bgroup+ (showsType px "")+ [ bench "Bytes" $ whnfIO (readOffMBytes mb (Off i :: Off a))+ , bench "ByteArray" $ whnfIO (BA.readByteArray mba i :: IO a)+ ]+ where i = 100++benchPeek ::+ forall a. (Typeable a, Prim a, BA.Prim a)+ => Proxy a+ -> MBytes 'Pin RealWorld+ -> BA.MutableByteArray RealWorld+ -> Benchmark+benchPeek px mb mba =+ bgroup+ (showsType px "")+ [ bench "Bytes" $ whnfIO $ withPtrMBytes mb (readPtr :: Ptr a -> IO a)+ , bench "ByteArray" $+ whnfIO $ do+ let ptr = BA.mutableByteArrayContents mba+ res <- S.peek ptr+ res <$ BA.touch mba+ ]++setBytesBench ::+ forall a . (Typeable a, BA.Prim a, Prim a)+ => MBytes 'Pin RealWorld+ -> MBytes 'Pin RealWorld+ -> BA.MutableByteArray RealWorld+ -> a+ -> Count a+ -> Benchmark+setBytesBench mb1 mb2 mba a c@(Count n) =+ bgroup (showsType (Proxy :: Proxy a) "")+ [ bench "setMBytes" $ nfIO (setMBytes mb1 0 c a)+ , bench "setOffPtr" $ nfIO (withPtrMBytes mb2 $ \ ptr -> setOffPtr ptr 0 c a :: IO ())+ , bench "setByteArray" $ nfIO (BA.setByteArray mba 0 n a)+ ]
+ bench/Conversion.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import GHC.Exts+import Criterion.Main+import Data.Prim.Memory.Bytes+import Data.Prim.Memory.Ptr+import Control.Prim.Monad+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 ()+main = do+ let n = 1000000 :: Count a+ n64 = n :: Count Word64+ xs = [1 .. unCount n]+ mb1 <- allocAlignedMBytes n64+ b1 <- freezeMBytes mb1+ mb2 <- allocAlignedMBytes n64+ mb3 <- allocAlignedMBytes n64+ let fp = toForeignPtrMBytes mb3+ mba <- BA.newAlignedPinnedByteArray (fromCount (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+ BA.setByteArray mbaEq1 0 (unCount n64) (0 :: Word64)+ BA.setByteArray mbaEq2 0 (unCount n64) (0 :: Word64)+ baEq1 <- BA.unsafeFreezeByteArray mbaEq1+ baEq2 <- BA.unsafeFreezeByteArray mbaEq2+ defaultMain+ [ bgroup+ "eq"+ [ bench "Bytes" $ whnf (bEq1 ==) bEq2+ , bench "ByteArray" $ whnf (baEq1 ==) baEq2+ ]+ , bgroup+ "with"+ [ bench "direct" $ nfIO (bytesAction n64 mb1)+ , bench "withPtrMBytes (INLINE)" $ nfIO (ptrAction_inline n64 mb3)+ , bench "withPtrMBytes (withNoHaltPtrMBytes)" $ nfIO (ptrAction n64 mb2)+ , bench "withPtrMBytes (NOINLINE)" $ nfIO (ptrAction_noinline n64 mb1)+ , bench "withForeignPtr (INLINE)" $ nfIO (foreignPtrAction n64 fp)+ , bench "withForeignPtr (Storable)" $ nfIO (foreignPtrStorable n64 fp)+ ]+ , bgroup+ "list"+ [ bgroup+ "mappend"+ [ bench "Bytes" $ whnf (mappend bEq1) bEq2+ , bench "ByteArray" $ whnf (mappend baEq1) baEq2+ ]+ , bgroup+ "mconcat"+ [ bench "Bytes" $ whnf mconcat [bEq1, bEq2, bEq1]+ , bench "ByteArray" $ whnf mconcat [baEq1, baEq2, baEq1]+ ]+ , env (pure (5 :: Int)) $ \sLen ->+ bgroup+ "stimes"+ [ bench "Bytes" $ whnf (stimes sLen) bEq1+ , bench "ByteArray" $ whnf (stimes sLen) baEq1+ ]+ , bgroup+ "toList"+ [ bench "Bytes" $ nf toList b1+ , bench "ByteArray" $ nf toList ba+ ]+ , bgroup+ "fromList"+ [ bench "Bytes" $ whnf (fromListBytes :: [Int] -> Bytes 'Inc) xs+ , bench "ByteArray" $ whnf BA.byteArrayFromList xs+ ]+ , bgroup+ "fromListN"+ [ bench "Bytes" $ whnf (fromListBytesN_ n :: [Int] -> Bytes 'Inc) xs+ , bench "ByteArray" $ whnf (BA.byteArrayFromListN (unCount n)) xs+ ]+ ]+ ]+++withPtrMBytes_noinline :: MBytes 'Pin s -> (Ptr a -> IO b) -> IO b+withPtrMBytes_noinline mb f = do+ res <- f $ toPtrMBytes mb+ res <$ touch mb+{-# NOINLINE withPtrMBytes_noinline #-}++ptrAction :: forall a . (Num a, Prim a) => Count a -> MBytes 'Pin RealWorld -> IO ()+ptrAction (Count n) mb = go 0+ where+ go i+ | i < n = do+ withNoHaltPtrMBytes mb $ \ptr -> (writeOffPtr ptr (Off i) (123 :: a) :: IO ())+ go (i + 1)+ | otherwise = pure ()++ptrAction_inline :: forall a . (Num a, Prim a) => Count a -> MBytes 'Pin RealWorld -> IO ()+ptrAction_inline (Count n) mb = go 0+ where+ go i+ | i < n = do+ withPtrMBytes mb $ \ptr -> writeOffPtr ptr (Off i) (123 :: a)+ go (i + 1)+ | otherwise = pure ()++ptrAction_noinline :: forall a . (Num a, Prim a) => Count a -> MBytes 'Pin RealWorld -> IO ()+ptrAction_noinline (Count n) mb = go 0+ where+ go i+ | i < n = do+ withPtrMBytes_noinline mb $ \ptr -> writeOffPtr ptr (Off i) (123 :: a)+ go (i + 1)+ | otherwise = pure ()++bytesAction :: forall a . (Num a, Prim a) => Count a -> MBytes 'Pin RealWorld -> IO ()+bytesAction (Count n) mb = go 0+ where+ go i+ | i < n = do+ writeOffMBytes mb (Off i) (123 :: a)+ go (i + 1)+ | otherwise = pure ()++foreignPtrAction :: forall a . (Num a, Prim a) => Count a -> ForeignPtr a -> IO ()+foreignPtrAction (Count n) fp = go 0+ where+ go i+ | i < n = do+ withForeignPtr fp $ \ptr -> writeOffPtr ptr (Off i) (123 :: a)+ go (i + 1)+ | otherwise = pure ()+++foreignPtrStorable :: forall a . (Num a, Storable a) => Count a -> ForeignPtr a -> IO ()+foreignPtrStorable (Count n) fp = go 0+ where+ go i+ | i < n = do+ GHC.withForeignPtr fp $ \ptr -> pokeElemOff ptr i (123 :: a)+ go (i + 1)+ | otherwise = pure ()
+ primal-memory.cabal view
@@ -0,0 +1,92 @@+name: primal-memory+version: 0.1.0.0+synopsis: Unified interface for memory managemenet.+description: Please see the README on GitHub at <https://github.com/lehins/primal#readme>+homepage: https://github.com/lehins/primal+license: BSD3+license-file: LICENSE+author: Alexey Kuleshevich+maintainer: alexey@kuleshevi.ch+copyright: 2020 Alexey Kuleshevich+category: Algorithms+build-type: Simple+extra-source-files: README.md+ , CHANGELOG.md+cabal-version: 1.18+tested-with: GHC == 8.4.3+ , GHC == 8.4.4+ , GHC == 8.6.3+ , GHC == 8.6.4+ , GHC == 8.6.5+ , GHC == 8.8.1+ , GHC == 8.8.2+ , GHC == 8.10.1++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.Ptr+ , Data.Prim.Memory.Internal+ , Data.Prim.Memory.ForeignPtr+ other-modules: Data.Prim.Memory.Bytes.Internal+ build-depends: base >= 4.8 && < 5+ , bytestring+ , deepseq+ , primal++ 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++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Bench.hs+ ghc-options: -Wall+ -threaded+ -O2+ -with-rtsopts=-N+ build-depends: base+ , criterion+ , primal+ , primal-memory+ , primitive+ , deepseq+ , random+ default-language: Haskell2010++benchmark convert+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Conversion.hs+ ghc-options: -Wall+ -threaded+ -O2+ -with-rtsopts=-N+ build-depends: base+ , criterion+ , primal+ , primal-memory+ , primitive+ , deepseq+ , random+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/lehins/prim-bytes
+ src/Data/Prim/Memory.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Data.Prim.Memory+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory+ ( Pinned(..)+ -- * Immutable+ , Bytes+ , MemRead+ , countMem+ , countRemMem+ , indexOffMem+ , eqMem+ , compareMem+ -- * Mutable+ , MBytes+ , MemAlloc(FrozenMem)+ , MemWrite+ , getCountMem+ , getCountRemMem+ , readOffMem+ , writeOffMem+ , modifyFetchOldMem+ , modifyFetchOldMemM+ , modifyFetchNewMem+ , modifyFetchNewMemM+ , setMem+ , copyMem+ , moveMem++ , 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+ ) where++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.
+ src/Data/Prim/Memory/Addr.hs view
@@ -0,0 +1,1058 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Prim.Memory.Addr+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.Addr+ ( -- * Immutable Addr+ Addr(..)+ , castAddr+ , fromBytesAddr+ , curOffAddr+ , byteCountAddr+ , countAddr+ , plusOffAddr+ , indexAddr+ , indexOffAddr+ , indexByteOffAddr+ , readAddr+ , readOffAddr+ , readByteOffAddr+ , thawAddr+ , freezeMAddr+ , withPtrAddr+ , withAddrAddr#+ , withNoHaltPtrAddr++ -- * Mutable MAddr+ , MAddr(..)+ , castMAddr+ , allocMAddr+ , callocMAddr+ , reallocMAddr+ , shrinkMAddr+ , shrinkByteCountMAddr+ , setMAddr+ , curOffMAddr+ , getByteCountMAddr+ , getCountMAddr+ , plusOffMAddr+ , readMAddr+ , readOffMAddr+ , readByteOffMAddr+ , writeMAddr+ , writeOffMAddr+ , writeByteOffMAddr+ , copyAddrToMAddr+ , moveMAddrToMAddr++ , withPtrMAddr+ , withAddrMAddr#+ , withNoHaltPtrMAddr+ , toForeignPtrAddr+ , toForeignPtrMAddr+ , fromForeignPtrAddr+ , fromForeignPtrMAddr+ -- * Conversion+ -- ** ByteString+ , toByteStringAddr+ , toShortByteStringAddr+ , fromShortByteStringAddr+ , fromByteStringAddr+ , fromByteStringMAddr++ -- * Atomic+ , casOffMAddr+ , casBoolOffMAddr+ , casBoolFetchOffMAddr+ , atomicReadOffMAddr+ , atomicWriteOffMAddr+ , atomicModifyOffMAddr+ , atomicModifyOffMAddr_+ , atomicModifyFetchOldOffMAddr+ , atomicModifyFetchNewOffMAddr+ -- ** Numeric+ , atomicAddFetchOldOffMAddr+ , atomicAddFetchNewOffMAddr+ , atomicSubFetchOldOffMAddr+ , atomicSubFetchNewOffMAddr+ -- ** Binary+ , atomicAndFetchOldOffMAddr+ , atomicAndFetchNewOffMAddr+ , atomicNandFetchOldOffMAddr+ , atomicNandFetchNewOffMAddr+ , atomicOrFetchOldOffMAddr+ , atomicOrFetchNewOffMAddr+ , atomicXorFetchOldOffMAddr+ , atomicXorFetchNewOffMAddr+ , atomicNotFetchOldOffMAddr+ , atomicNotFetchNewOffMAddr+ -- * Prefetch+ -- ** Directly+ , prefetchAddr0+ , prefetchMAddr0+ , prefetchAddr1+ , prefetchMAddr1+ , prefetchAddr2+ , prefetchMAddr2+ , prefetchAddr3+ , prefetchMAddr3+ -- ** With offset+ , prefetchOffAddr0+ , prefetchOffMAddr0+ , prefetchOffAddr1+ , prefetchOffMAddr1+ , prefetchOffAddr2+ , prefetchOffMAddr2+ , prefetchOffAddr3+ , prefetchOffMAddr3+ -- * Re-export+ , module Data.Prim+ ) where++import Control.Arrow (first)+import Control.DeepSeq+import Control.Prim.Monad+import Control.Prim.Monad.Unsafe+import Data.ByteString.Internal+import Data.ByteString.Short.Internal+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Monoid as Monoid+import Data.Prim+import Data.Prim.Atomic+import Data.Prim.Class+import Data.Prim.Memory.Bytes+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+++data Addr e = Addr+ { addrAddr# :: Addr#+ , addrBytes :: {-# UNPACK #-}!(Bytes 'Pin)+ }+type role Addr representational+++data MAddr e s = MAddr+ { mAddrAddr# :: Addr#+ , mAddrMBytes :: {-# UNPACK #-}!(MBytes 'Pin s)+ }+type role MAddr representational nominal++++instance Eq (Addr e) where+ a1 == a2 = isSameAddr a1 a2 || eqMem a1 a2++instance (Show e, Prim e) => Show (Addr e) where+ show a = show (toListMem a :: [e])++instance IsString (Addr Char) where+ fromString = fromListMem++instance Prim e => IsList (Addr e) where+ type Item (Addr e) = e+ fromList = fromListMem+ fromListN n = fromListMemN_ (Count n)+ toList = toListMem++instance Semigroup.Semigroup (Addr e) where+ (<>) = appendMem+ sconcat (x :| xs) = concatMem (x:xs)+ stimes i = cycleMemN (fromIntegral i)++instance Monoid.Monoid (Addr e) where+ mappend = appendMem+ mconcat = concatMem+ mempty = emptyMem+++castAddr :: Addr e -> Addr b+castAddr (Addr a b) = Addr a b++castMAddr :: MAddr e s -> MAddr b s+castMAddr (MAddr a mb) = MAddr a mb++isSameAddr :: Addr e -> Addr e -> Bool+isSameAddr (Addr a1# _) (Addr a2# _) = isTrue# (a1# `eqAddr#` a2#)++instance NFData (Addr e) where+ rnf (Addr _ _) = ()++instance NFData (MAddr e s) where+ rnf (MAddr _ _) = ()++toBytesAddr :: Addr e -> (Bytes 'Pin, Off Word8)+toBytesAddr addr@(Addr _ b) = (b, curByteOffAddr addr)++fromBytesAddr :: Bytes 'Pin -> Addr e+fromBytesAddr b@(Bytes b#) = Addr (byteArrayContents# b#) b++fromMBytesMAddr :: MBytes 'Pin s -> MAddr e s+fromMBytesMAddr mb =+ case toPtrMBytes mb of+ Ptr addr# -> MAddr addr# mb++allocMAddr :: (MonadPrim s m, Prim e) => Count e -> m (MAddr e s)+allocMAddr c = fromMBytesMAddr <$> allocAlignedMBytes c++callocMAddr :: (MonadPrim s m, Prim e) => Count e -> m (MAddr e s)+callocMAddr c = fromMBytesMAddr <$> callocAlignedMBytes c+++-- | Shrink mutable address to new specified size in number of elements. The new count+-- must be less than or equal to the current as reported by `getCountMAddr`.+shrinkMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Count e -> m ()+shrinkMAddr maddr@(MAddr _ mb) c = shrinkMBytes mb (toByteCount c + coerce (curByteOffMAddr maddr))+{-# INLINE shrinkMAddr #-}++-- | Shrink mutable address to new specified size in bytes. The new count must be less+-- than or equal to the current as reported by `getByteCountMAddr`.+shrinkByteCountMAddr :: MonadPrim s m => MAddr e s -> Count Word8 -> m ()+shrinkByteCountMAddr maddr@(MAddr _ mb) c = shrinkMBytes mb (c + coerce (curByteOffMAddr maddr))+{-# INLINE shrinkByteCountMAddr #-}+++reallocMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Count e -> m (MAddr e s)+reallocMAddr maddr c = do+ oldByteCount <- getByteCountMAddr maddr+ let newByteCount = toByteCount c+ if newByteCount <= oldByteCount+ then maddr <$+ when (newByteCount < oldByteCount) (shrinkByteCountMAddr maddr newByteCount)+ else do+ addr <- freezeMAddr maddr+ maddr' <- allocMAddr newByteCount+ castMAddr maddr' <$+ copyAddrToMAddr (castAddr addr) 0 maddr' 0 oldByteCount+{-# INLINABLE reallocMAddr #-}+++plusOffAddr :: Prim e => Addr e -> Off e -> Addr e+plusOffAddr (Addr addr# b) off = Addr (addr# `plusAddr#` fromOff# off) b++plusOffMAddr :: Prim e => MAddr e s -> Off e -> MAddr e s+plusOffMAddr (MAddr addr# mb) off = MAddr (addr# `plusAddr#` fromOff# off) mb++curOffAddr :: Prim e => Addr e -> Off e+curOffAddr a@(Addr addr# b) = offAsProxy a (Ptr addr# `minusOffPtr` toPtrBytes b)++curByteOffAddr :: Addr e -> Off Word8+curByteOffAddr (Addr addr# b) = Ptr addr# `minusByteOffPtr` toPtrBytes b++countAddr ::+ forall e. Prim e+ => Addr e+ -> Count e+countAddr addr@(Addr _ b) = countBytes b - coerce (curOffAddr addr)++byteCountAddr :: Addr e -> Count Word8+byteCountAddr = countAddr . castAddr++getCountMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> m (Count e)+getCountMAddr maddr@(MAddr _ mb) =+ subtract (coerce (curOffMAddr maddr)) <$> getCountMBytes mb++getByteCountMAddr :: MonadPrim s m => MAddr e s -> m (Count Word8)+getByteCountMAddr = getCountMAddr . castMAddr++indexAddr :: Prim e => Addr e -> e+indexAddr addr = indexOffAddr addr 0++indexOffAddr :: Prim e => Addr e -> Off e -> e+indexOffAddr addr off = unsafeInlineIO $ readOffAddr addr off++indexByteOffAddr :: Prim e => Addr e -> Off Word8 -> e+indexByteOffAddr addr off = unsafeInlineIO $ readByteOffAddr addr off++withPtrAddr :: MonadPrim s m => Addr e -> (Ptr e -> m b) -> m b+withPtrAddr addr f = withAddrAddr# addr $ \addr# -> f (Ptr addr#)+{-# INLINE withPtrAddr #-}++withAddrAddr# :: MonadPrim s m => Addr e -> (Addr# -> m b) -> m b+withAddrAddr# (Addr addr# b) f = do+ a <- f addr#+ a <$ touch b+{-# INLINE withAddrAddr# #-}++withNoHaltPtrAddr :: MonadUnliftPrim s m => Addr e -> (Ptr e -> m b) -> m b+withNoHaltPtrAddr (Addr addr# b) f = withAliveUnliftPrim b $ f (Ptr addr#)+{-# INLINE withNoHaltPtrAddr #-}++curOffMAddr :: forall e s . Prim e => MAddr e s -> Off e+curOffMAddr (MAddr addr# mb) = (Ptr addr# :: Ptr e) `minusOffPtr` toPtrMBytes mb++curByteOffMAddr :: forall e s . MAddr e s -> Off Word8+curByteOffMAddr (MAddr addr# mb) = (Ptr addr# :: Ptr e) `minusByteOffPtr` toPtrMBytes mb++withPtrMAddr :: MonadPrim s m => MAddr e s -> (Ptr e -> m b) -> m b+withPtrMAddr maddr f = withAddrMAddr# maddr $ \addr# -> f (Ptr addr#)+{-# INLINE withPtrMAddr #-}++++toForeignPtrAddr :: Addr e -> ForeignPtr e+toForeignPtrAddr (Addr addr# (Bytes ba#)) = ForeignPtr addr# (PlainPtr (unsafeCoerce# ba#))+++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`+--+-- @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++-- | 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++++withAddrMAddr# :: MonadPrim s m => MAddr e s -> (Addr# -> m b) -> m b+withAddrMAddr# (MAddr addr# mb) f = do+ a <- f addr#+ a <$ touch mb+{-# INLINE withAddrMAddr# #-}++withNoHaltPtrMAddr :: MonadUnliftPrim s m => MAddr e s -> (Ptr e -> m b) -> m b+withNoHaltPtrMAddr (MAddr addr# mb) f = withAliveUnliftPrim mb $ f (Ptr addr#)+{-# INLINE withNoHaltPtrMAddr #-}++++-- | Read-only access, but it is not enforced.+instance PtrAccess s (Addr e) where+ toForeignPtr = pure . toForeignPtrAddr . castAddr+ {-# INLINE toForeignPtr #-}+ withPtrAccess addr = withPtrAddr (castAddr addr)+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess addr = withNoHaltPtrAddr (castAddr addr)+ {-# INLINE withNoHaltPtrAccess #-}++instance PtrAccess s (MAddr e s) where+ toForeignPtr = pure . toForeignPtrMAddr . castMAddr+ {-# INLINE toForeignPtr #-}+ withPtrAccess maddr = withPtrMAddr (castMAddr maddr)+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess maddr = withNoHaltPtrMAddr (castMAddr maddr)+ {-# INLINE withNoHaltPtrAccess #-}++++instance MemAlloc (MAddr e) where+ type FrozenMem (MAddr e) = Addr e++ getByteCountMem = getByteCountMAddr+ {-# INLINE getByteCountMem #-}+ allocByteCountMem = fmap castMAddr . allocMAddr+ {-# INLINE allocByteCountMem #-}+ thawMem = thawAddr+ {-# INLINE thawMem #-}+ freezeMem = freezeMAddr+ {-# INLINE freezeMem #-}+ resizeMem maddr = fmap castMAddr . reallocMAddr (castMAddr maddr)+ {-# INLINE resizeMem #-}+++instance MemRead (Addr e) where+ byteCountMem = byteCountAddr+ {-# INLINE byteCountMem #-}+ indexOffMem a i = unsafeInlineIO $ withAddrAddr# a $ \addr# -> readOffPtr (Ptr addr#) i+ {-# INLINE indexOffMem #-}+ indexByteOffMem a i = unsafeInlineIO $ withAddrAddr# a $ \addr# -> readByteOffPtr (Ptr addr#) i+ {-# INLINE indexByteOffMem #-}+ copyByteOffToMBytesMem a si mb di c =+ withPtrAddr a $ \ptr -> copyByteOffPtrToMBytes (castPtr ptr) si mb di c+ {-# INLINE copyByteOffToMBytesMem #-}+ copyByteOffToPtrMem a si mb di c =+ withPtrAddr a $ \ptr -> copyByteOffPtrToPtr (castPtr ptr) si mb di c+ {-# INLINE copyByteOffToPtrMem #-}+ compareByteOffToPtrMem addr off1 ptr2 off2 c =+ 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+ {-# INLINE compareByteOffToBytesMem #-}+ compareByteOffMem mem1 off1 addr off2 c =+ unsafeInlineIO $ withPtrAccess addr $ \ptr2 -> compareByteOffToPtrMem mem1 off1 ptr2 off2 c+ {-# INLINE compareByteOffMem #-}++instance MemWrite (MAddr e) where+ readOffMem a = readOffMAddr (castMAddr a)+ {-# INLINE readOffMem #-}+ readByteOffMem a = readByteOffMAddr (castMAddr a)+ {-# INLINE readByteOffMem #-}+ writeOffMem a = writeOffMAddr (castMAddr a)+ {-# INLINE writeOffMem #-}+ writeByteOffMem a = writeByteOffMAddr (castMAddr a)+ {-# INLINE writeByteOffMem #-}+ moveByteOffToPtrMem src srcOff dstPtr dstOff c =+ withAddrMAddr# src $ \ srcAddr# ->+ moveByteOffPtrToPtr (Ptr srcAddr#) srcOff dstPtr dstOff c+ {-# INLINE moveByteOffToPtrMem #-}+ moveByteOffToMBytesMem src srcOff dst dstOff c =+ withAddrMAddr# src $ \ srcAddr# ->+ moveByteOffPtrToMBytes (Ptr srcAddr#) srcOff dst dstOff c+ {-# INLINE moveByteOffToMBytesMem #-}+ copyByteOffMem src srcOff dst dstOff c =+ withAddrMAddr# dst $ \ dstAddr# ->+ copyByteOffToPtrMem src srcOff (Ptr dstAddr#) dstOff c+ {-# INLINE copyByteOffMem #-}+ moveByteOffMem src srcOff dst dstOff c =+ withAddrMAddr# dst $ \ dstAddr# ->+ moveByteOffToPtrMem src srcOff (Ptr dstAddr#) dstOff c+ {-# INLINE moveByteOffMem #-}+ setMem maddr = setMAddr (castMAddr maddr)+ {-# INLINE setMem #-}++++thawAddr :: MonadPrim s m => Addr e -> m (MAddr e s)+thawAddr (Addr addr# b) = MAddr addr# <$> thawBytes b+{-# INLINE thawAddr #-}++freezeMAddr :: MonadPrim s m => MAddr e s -> m (Addr e)+freezeMAddr (MAddr addr# mb) = Addr addr# <$> freezeMBytes mb+{-# INLINE freezeMAddr #-}+++readAddr :: (MonadPrim s m, Prim e) => Addr e -> m e+readAddr addr = readOffAddr addr 0+{-# INLINE readAddr #-}++readOffAddr :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m e+readOffAddr (Addr addr# b) (Off (I# off#)) = do+ -- TODO: benchmark and see if `readOffAddr` is faster here+ a <- prim (seq# (indexOffAddr# addr# off#))+ a <$ touch b+{-# INLINE readOffAddr #-}++readByteOffAddr :: (MonadPrim s m, Prim e) => Addr e -> Off Word8 -> m e+readByteOffAddr (Addr addr# b) (Off (I# off#)) = do+ a <- prim (seq# (indexOffAddr# (addr# `plusAddr#` off#) 0#))+ a <$ touch b+{-# INLINE readByteOffAddr #-}+++readMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> m e+readMAddr maddr = readOffMAddr maddr 0+{-# INLINE readMAddr #-}++readOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m e+readOffMAddr (MAddr addr# mb) (Off (I# off#)) = do+ a <- prim (readOffAddr# addr# off#)+ a <$ touch mb+{-# INLINE readOffMAddr #-}++readByteOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off Word8 -> m e+readByteOffMAddr (MAddr addr# mb) (Off (I# off#)) = do+ a <- prim (readOffAddr# (addr# `plusAddr#` off#) 0#)+ a <$ touch mb+{-# INLINE readByteOffMAddr #-}++writeMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> e -> m ()+writeMAddr maddr = writeOffMAddr maddr 0+{-# INLINE writeMAddr #-}++writeOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> e -> m ()+writeOffMAddr (MAddr addr# mb) (Off (I# off#)) a =+ prim_ (writeOffAddr# addr# off# a) >> touch mb+{-# INLINE writeOffMAddr #-}++writeByteOffMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off Word8 -> e -> m ()+writeByteOffMAddr (MAddr addr# mb) (Off (I# off#)) a =+ prim_ (writeOffAddr# (addr# `plusAddr#` off#) 0# a) >> touch mb+{-# INLINE writeByteOffMAddr #-}+++copyAddrToMAddr ::+ (MonadPrim s m, Prim e) => Addr e -> Off e -> MAddr e s -> Off e -> Count e -> m ()+copyAddrToMAddr src srcOff dst dstOff c =+ withPtrAddr src $ \ srcPtr ->+ withPtrMAddr dst $ \ dstPtr ->+ copyPtrToPtr srcPtr srcOff dstPtr dstOff c+{-# INLINE copyAddrToMAddr #-}++moveMAddrToMAddr ::+ (MonadPrim s m, Prim e) => MAddr e s -> Off e -> MAddr e s -> Off e -> Count e -> m ()+moveMAddrToMAddr src srcOff dst dstOff c =+ withPtrMAddr src $ \ srcPtr ->+ withPtrMAddr dst $ \ dstPtr ->+ movePtrToPtr srcPtr srcOff dstPtr dstOff c+{-# INLINE moveMAddrToMAddr #-}++setMAddr :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> Count e -> e -> m ()+setMAddr (MAddr addr# mb) (Off (I# off#)) (Count (I# n#)) a =+ prim_ (setOffAddr# addr# off# n# a) >> touch mb+{-# INLINE setMAddr #-}++++-- | /O(1)/ - Cast an immutable `Addr` to an immutable `ByteString`+--+-- @since 0.1.0+toByteStringAddr :: Addr Word8 -> ByteString+toByteStringAddr addr = PS (toForeignPtrAddr addr) 0 (unCount (countAddr addr))++-- | /O(1)/ - Cast an immutable `Addr` to an immutable `ShortByteString`+--+-- @since 0.1.0+toShortByteStringAddr :: Addr Word8 -> (ShortByteString, Off Word8)+toShortByteStringAddr = first toShortByteStringBytes . toBytesAddr++-- | /O(1)/ - Cast 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`.+--+-- @since 0.1.0+fromShortByteStringAddr :: ShortByteString -> Addr Word8+fromShortByteStringAddr = fromBytesAddr . ensurePinnedBytes . fromShortByteStringBytes++-- | /O(1)/ - Cast an immutable `ByteString` to `Addr`. Also returns the original length of+-- ByteString, which will be less or equal to `countOfAddr` in the produced `Addr`.+--+-- @since 0.1.0+fromByteStringAddr :: ByteString -> (Addr Word8, Count Word8)+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"++-- | /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+-- produced `MAddr`.+--+-- __Unsafe__ - Further modification of `MAddr` will affect the source `ByteString`+--+-- @since 0.1.0+fromByteStringMAddr :: ByteString -> (MAddr Word8 s, Count Word8)+fromByteStringMAddr (PS fptr i n) =+ case fromForeignPtrMAddr fptr of+ Just maddr -> (maddr `plusOffMAddr` Off i, Count n)+ Nothing -> byteStringConvertError "It was allocated outside of 'bytestring' package"++++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Returns the artifact of computation @__b__@. Offset is in number of elements,+-- rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m e+casOffMAddr maddr (Off (I# i#)) old new =+ withAddrMAddr# maddr $ \ addr# -> prim $ casOffAddr# addr# i# old new+{-# INLINE casOffMAddr #-}+++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Returns `True` if swap was successfull and false otherwise. Offset is in number+-- of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casBoolOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m Bool+casBoolOffMAddr maddr (Off (I# i#)) old new =+ withAddrMAddr# maddr $ \ addr# -> prim $ casBoolOffAddr# addr# i# old new+{-# INLINE casBoolOffMAddr #-}++-- | Just like `casBoolOffMAddr`, but also returns the actual value, which will match the+-- supplied expected value if the returned flag is `True`+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casBoolFetchOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m (Bool, e)+casBoolFetchOffMAddr maddr (Off (I# i#)) expected new = do+ withAddrMAddr# maddr $ \addr# ->+ prim $ \s ->+ case casBoolOffAddr# addr# i# expected new s of+ (# s', isCasSucc #)+ | isCasSucc -> (# s', (True, new) #)+ | otherwise ->+ case readOffAddr# addr# i# s' of+ (# s'', actual #) -> (# s'', (False, actual) #)+{-# INLINE casBoolFetchOffMAddr #-}+++-- | Perform atomic read of an element in the `MAddr` at the supplied offset. Offset is in+-- number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicReadOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> m e+atomicReadOffMAddr maddr (Off (I# i#)) =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicReadOffAddr# addr# i#+{-# INLINE atomicReadOffMAddr #-}++-- | Perform atomic write of an element in the `MAddr` at the supplied offset. Offset is in+-- number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicWriteOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> e+ -> m ()+atomicWriteOffMAddr maddr (Off (I# i#)) e =+ withAddrMAddr# maddr $ \ addr# -> prim_ $ atomicWriteOffAddr# addr# i# e+{-# INLINE atomicWriteOffMAddr #-}+++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Returns the artifact of computation @__b__@. Offset is in number of elements,+-- rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> (e -> (e, b)) -- ^ Function that is applied to the old value and returns new value+ -- and some artifact of computation @__b__@+ -> m b+atomicModifyOffMAddr maddr (Off (I# i#)) f =+ withAddrMAddr# maddr $ \ addr# -> prim $+ atomicModifyOffAddr# addr# i# $ \a ->+ case f a of+ (a', b) -> (# a', b #)+{-# INLINE atomicModifyOffMAddr #-}++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Offset is in number of elements, rather than bytes. Implies a full memory+-- barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyOffMAddr_ ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the current value+ -> m ()+atomicModifyOffMAddr_ maddr (Off (I# i#)) f =+ withAddrMAddr# maddr $ \ addr# -> prim_ $ atomicModifyOffAddr_# addr# i# f+{-# INLINE atomicModifyOffMAddr_ #-}+++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Returns the previous value. Offset is in number of elements, rather than+-- bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyFetchOldOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the old value+ -> m e -- ^ Returns the old value+atomicModifyFetchOldOffMAddr maddr (Off (I# i#)) f =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicModifyFetchOldOffAddr# addr# i# f+{-# INLINE atomicModifyFetchOldOffMAddr #-}+++-- | Perform atomic modification of an element in the `MAddr` at the supplied+-- index. Offset is in number of elements, rather than bytes. Implies a full memory+-- barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyFetchNewOffMAddr ::+ (MonadPrim s m, Atomic e)+ => MAddr e s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__e__@, rather than bytes+ -> (e -> e) -- ^ Function that is applied to the old value+ -> m e -- ^ Returns the new value+atomicModifyFetchNewOffMAddr maddr (Off (I# i#)) f =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicModifyFetchNewOffAddr# addr# i# f+{-# INLINE atomicModifyFetchNewOffMAddr #-}++++-- | Add a numeric value to an element of a `MAddr`, corresponds to @(`+`)@ done+-- atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAddFetchOldOffMAddr ::+ (MonadPrim s m, AtomicCount e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicAddFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicAddFetchOldOffAddr# addr# i# a+{-# INLINE atomicAddFetchOldOffMAddr #-}++-- | Add a numeric value to an element of a `MAddr`, corresponds to @(`+`)@ done+-- atomically. Returns the new value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAddFetchNewOffMAddr ::+ (MonadPrim s m, AtomicCount e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicAddFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicAddFetchNewOffAddr# addr# i# a+{-# INLINE atomicAddFetchNewOffMAddr #-}++++-- | Subtract a numeric value from an element of a `MAddr`, corresponds to+-- @(`-`)@ done atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicSubFetchOldOffMAddr ::+ (MonadPrim s m, AtomicCount e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicSubFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicSubFetchOldOffAddr# addr# i# a+{-# INLINE atomicSubFetchOldOffMAddr #-}++-- | Subtract a numeric value from an element of a `MAddr`, corresponds to+-- @(`-`)@ done atomically. Returns the new value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicSubFetchNewOffMAddr ::+ (MonadPrim s m, AtomicCount e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicSubFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicSubFetchNewOffAddr# addr# i# a+{-# INLINE atomicSubFetchNewOffMAddr #-}++++-- | Binary conjunction (AND) of an element of a `MAddr` with the supplied value,+-- corresponds to @(`Data.Bits..&.`)@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAndFetchOldOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicAndFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicAndFetchOldOffAddr# addr# i# a+{-# INLINE atomicAndFetchOldOffMAddr #-}++-- | Binary conjunction (AND) of an element of a `MAddr` with the supplied value,+-- corresponds to @(`Data.Bits..&.`)@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAndFetchNewOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicAndFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicAndFetchNewOffAddr# addr# i# a+{-# INLINE atomicAndFetchNewOffMAddr #-}++++-- | Negation of binary conjunction (NAND) of an element of a `MAddr` with the+-- supplied value, corresponds to @\\x y -> `Data.Bits.complement` (x `Data.Bits..&.` y)@+-- done atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNandFetchOldOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicNandFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicNandFetchOldOffAddr# addr# i# a+{-# INLINE atomicNandFetchOldOffMAddr #-}++-- | Negation of binary conjunction (NAND) of an element of a `MAddr` with the supplied+-- value, corresponds to @\\x y -> `Data.Bits.complement` (x `Data.Bits..&.` y)@ done+-- atomically. Returns the new value. Offset is in number of elements, rather than+-- bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNandFetchNewOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicNandFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicNandFetchNewOffAddr# addr# i# a+{-# INLINE atomicNandFetchNewOffMAddr #-}+++++-- | Binary disjunction (OR) of an element of a `MAddr` with the supplied value,+-- corresponds to @(`Data.Bits..|.`)@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicOrFetchOldOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicOrFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicOrFetchOldOffAddr# addr# i# a+{-# INLINE atomicOrFetchOldOffMAddr #-}++-- | Binary disjunction (OR) of an element of a `MAddr` with the supplied value,+-- corresponds to @(`Data.Bits..|.`)@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicOrFetchNewOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicOrFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicOrFetchNewOffAddr# addr# i# a+{-# INLINE atomicOrFetchNewOffMAddr #-}++++-- | Binary exclusive disjunction (XOR) of an element of a `MAddr` with the supplied value,+-- corresponds to @`Data.Bits.xor`@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicXorFetchOldOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicXorFetchOldOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicXorFetchOldOffAddr# addr# i# a+{-# INLINE atomicXorFetchOldOffMAddr #-}++-- | Binary exclusive disjunction (XOR) of an element of a `MAddr` with the supplied value,+-- corresponds to @`Data.Bits.xor`@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicXorFetchNewOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> e+ -> m e+atomicXorFetchNewOffMAddr maddr (Off (I# i#)) a =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicXorFetchNewOffAddr# addr# i# a+{-# INLINE atomicXorFetchNewOffMAddr #-}++++++-- | Binary negation (NOT) of an element of a `MAddr`, corresponds to+-- @(`Data.Bits.complement`)@ done atomically. Returns the previous value. Offset is in+-- number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNotFetchOldOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> m e+atomicNotFetchOldOffMAddr maddr (Off (I# i#)) =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicNotFetchOldOffAddr# addr# i#+{-# INLINE atomicNotFetchOldOffMAddr #-}++-- | Binary negation (NOT) of an element of a `MAddr`, corresponds to+-- @(`Data.Bits.complement`)@ done atomically. Returns the new value. Offset is in number+-- of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNotFetchNewOffMAddr ::+ (MonadPrim s m, AtomicBits e)+ => MAddr e s+ -> Off e+ -> m e+atomicNotFetchNewOffMAddr maddr (Off (I# i#)) =+ withAddrMAddr# maddr $ \ addr# -> prim $ atomicNotFetchNewOffAddr# addr# i#+{-# INLINE atomicNotFetchNewOffMAddr #-}+++++prefetchAddr0 :: MonadPrim s m => Addr e -> m ()+prefetchAddr0 (Addr addr# _) = prim_ (prefetchAddr0# addr# 0#)+{-# INLINE prefetchAddr0 #-}++prefetchMAddr0 :: MonadPrim s m => MAddr e s -> m ()+prefetchMAddr0 (MAddr maddr# _) = prim_ (prefetchAddr0# maddr# 0#)+{-# INLINE prefetchMAddr0 #-}++prefetchAddr1 :: MonadPrim s m => Addr e -> m ()+prefetchAddr1 (Addr addr# _) = prim_ (prefetchAddr1# addr# 0#)+{-# INLINE prefetchAddr1 #-}++prefetchMAddr1 :: MonadPrim s m => MAddr e s -> m ()+prefetchMAddr1 (MAddr maddr# _) = prim_ (prefetchAddr1# maddr# 0#)+{-# INLINE prefetchMAddr1 #-}++prefetchAddr2 :: MonadPrim s m => Addr e -> m ()+prefetchAddr2 (Addr addr# _) = prim_ (prefetchAddr2# addr# 0#)+{-# INLINE prefetchAddr2 #-}++prefetchMAddr2 :: MonadPrim s m => MAddr e s -> m ()+prefetchMAddr2 (MAddr maddr# _) = prim_ (prefetchAddr2# maddr# 0#)+{-# INLINE prefetchMAddr2 #-}++prefetchAddr3 :: MonadPrim s m => Addr e -> m ()+prefetchAddr3 (Addr addr# _) = prim_ (prefetchAddr3# addr# 0#)+{-# INLINE prefetchAddr3 #-}++prefetchMAddr3 :: MonadPrim s m => MAddr e s -> m ()+prefetchMAddr3 (MAddr maddr# _) = prim_ (prefetchAddr3# maddr# 0#)+{-# INLINE prefetchMAddr3 #-}+++prefetchOffAddr0 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m ()+prefetchOffAddr0 (Addr addr# _) off = prim_ (prefetchAddr0# addr# (fromOff# off))+{-# INLINE prefetchOffAddr0 #-}++prefetchOffMAddr0 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m ()+prefetchOffMAddr0 (MAddr maddr# _) off = prim_ (prefetchAddr0# maddr# (fromOff# off))+{-# INLINE prefetchOffMAddr0 #-}++prefetchOffAddr1 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m ()+prefetchOffAddr1 (Addr addr# _) off = prim_ (prefetchAddr1# addr# (fromOff# off))+{-# INLINE prefetchOffAddr1 #-}++prefetchOffMAddr1 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m ()+prefetchOffMAddr1 (MAddr maddr# _) off = prim_ (prefetchAddr1# maddr# (fromOff# off))+{-# INLINE prefetchOffMAddr1 #-}++prefetchOffAddr2 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m ()+prefetchOffAddr2 (Addr addr# _) off = prim_ (prefetchAddr2# addr# (fromOff# off))+{-# INLINE prefetchOffAddr2 #-}++prefetchOffMAddr2 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m ()+prefetchOffMAddr2 (MAddr maddr# _) off = prim_ (prefetchAddr2# maddr# (fromOff# off))+{-# INLINE prefetchOffMAddr2 #-}++prefetchOffAddr3 :: (MonadPrim s m, Prim e) => Addr e -> Off e -> m ()+prefetchOffAddr3 (Addr addr# _) off = prim_ (prefetchAddr3# addr# (fromOff# off))+{-# INLINE prefetchOffAddr3 #-}++prefetchOffMAddr3 :: (MonadPrim s m, Prim e) => MAddr e s -> Off e -> m ()+prefetchOffMAddr3 (MAddr maddr# _) off = prim_ (prefetchAddr3# maddr# (fromOff# off))+{-# INLINE prefetchOffMAddr3 #-}
+ src/Data/Prim/Memory/ByteArray.hs view
@@ -0,0 +1,311 @@+{-# 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 <alexey@kuleshevi.ch>+-- 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 #-}+
+ src/Data/Prim/Memory/ByteString.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+-- |+-- Module : Data.Prim.Memory.ByteString+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.ByteString+ (+ MByteString(..)+ -- * Conversion+ -- Builder+ , Builder+ , toBuilderBytes+ , fromBuilderBytes+ -- ** ByteString+ , ByteString(..)+ , toByteStringBytes+ , fromByteStringBytes+ , fromLazyByteStringBytes+ , withPtrByteString+ , withNoHaltPtrByteString+ -- ** ShortByteString+ , ShortByteString(..)+ , toShortByteStringBytes+ , fromShortByteStringBytes+ , byteStringConvertError+ ) where++import Control.Monad.ST+import Data.ByteString.Builder+import Data.ByteString.Internal+import Data.ByteString.Short.Internal+import qualified Data.ByteString.Lazy as BSL+import Data.Prim+import Foreign.Prim+import Control.Prim.Monad+import GHC.ForeignPtr+import Data.Prim.Memory.Ptr+import Data.Prim.Memory.Bytes.Internal+ ( Bytes(..)+ , Pinned(..)+ , allocMBytes+ , freezeMBytes+ , byteCountBytes+ , toForeignPtrBytes+ , fromForeignPtrBytes+ , byteStringConvertError+ )++-- | Mutable version of a `ByteString`+newtype MByteString s = MByteString ByteString+++-- | /O(1)/ - Cast an 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 #-}++-- | /O(1)/ - Cast an immutable `Bytes` to an immutable `ShortByteString`+--+-- @since 0.1.0+toShortByteStringBytes :: Bytes p -> ShortByteString+toShortByteStringBytes (Bytes ba#) = SBS ba#+{-# INLINE toShortByteStringBytes #-}++-- | /O(1)/ - Cast an immutable `ShortByteString` to an immutable `Bytes`+--+-- @since 0.1.0+fromShortByteStringBytes :: ShortByteString -> Bytes 'Inc+fromShortByteStringBytes (SBS ba#) = Bytes ba#+{-# INLINE fromShortByteStringBytes #-}++-- | Convert `Bytes` into a bytestring `Builder`+toBuilderBytes :: Bytes p -> Builder+toBuilderBytes = shortByteString . toShortByteStringBytes+{-# INLINE[1] toBuilderBytes #-}+{-# RULES+"toBuilderBytes" toBuilderBytes = byteString . toByteStringBytes+ #-}++-- | /O(n)/ - Allocate `Bytes` and fill them using the supplied `Builder`+fromBuilderBytes :: Builder -> Bytes 'Pin+fromBuilderBytes b = fromLazyByteStringBytes (toLazyByteString b)+{-# INLINE fromBuilderBytes #-}+++-- | /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+{-# INLINE fromLazyByteStringBytes #-}+++-- | /O(n)/ - Allocate `Bytes` and fill them with the contents of a strict `ByteString`+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+{-# 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#))+ 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#))+{-# INLINE withNoHaltPtrByteString #-}
+ src/Data/Prim/Memory/Bytes.hs view
@@ -0,0 +1,939 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Prim.Memory.Bytes+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.Bytes+ ( -- * Mutable+ Bytes+ , toByteArray#+ , fromByteArray#+ , cloneBytes+ , emptyBytes+ , eqBytes+ , singletonBytes+ , isEmptyBytes+ , createBytes+ , createBytes_+ , createBytesST+ , createBytesST_+ -- * Pinness+ , Pinned(..)+ , isPinnedBytes+ , isPinnedMBytes+ , toPinnedBytes+ , toPinnedMBytes+ , relaxPinnedBytes+ , relaxPinnedMBytes+ , ensurePinnedBytes+ , ensurePinnedMBytes+ -- * Mutable+ , MBytes+ , toMutableByteArray#+ , fromMutableByteArray#+ , isSameBytes+ , isSamePinnedBytes+ , isSameMBytes+ , indexOffBytes+ , indexByteOffBytes+ , byteCountBytes+ , countBytes+ , countRemBytes+ , compareBytes+ , compareByteOffBytes+ -- * Mutable+ -- ** To/From immutable+ , thawBytes+ , freezeMBytes+ -- ** Construction+ , allocMBytes+ , singletonMBytes+ , allocPinnedMBytes+ , allocAlignedMBytes+ , allocUnpinnedMBytes+ , callocMBytes+ , callocAlignedMBytes+ , shrinkMBytes+ , resizeMBytes+ , reallocMBytes+ , coerceStateMBytes+ -- ** Modifying data+ , cloneMBytes+ , withCloneMBytes+ , withCloneMBytes_+ , withCloneMBytesST+ , withCloneMBytesST_+ , loadListMBytes+ , loadListMBytes_+ , copyBytesToMBytes+ , moveMBytesToMBytes+ -- ** Moving data+ -- * Size+ , getByteCountMBytes+ , getCountMBytes+ , getCountRemOfMBytes+ -- * Access+ , readOffMBytes+ , readByteOffMBytes+ , writeOffMBytes+ , writeByteOffMBytes+ , setMBytes+ , zeroMBytes+ -- ** Ptr+ , withPtrBytes+ , withNoHaltPtrBytes+ , withPtrMBytes+ , withNoHaltPtrMBytes+ , toPtrBytes+ , toPtrMBytes+ , toForeignPtrBytes+ , toForeignPtrMBytes+ -- * Conversion+ , fromListBytes+ , fromListBytesN+ , fromListBytesN_+ , appendBytes+ , concatBytes+ , toListBytes+ , toListSlackBytes+ -- * Atomic+ , casMBytes+ , casBoolMBytes+ , casBoolFetchMBytes+ , atomicReadMBytes+ , atomicWriteMBytes+ , atomicModifyMBytes+ , atomicModifyMBytes_+ , atomicBoolModifyFetchOldMBytes+ , atomicModifyFetchOldMBytes+ , atomicModifyFetchNewMBytes+ -- ** Numberic+ , atomicAddFetchOldMBytes+ , atomicAddFetchNewMBytes+ , atomicSubFetchOldMBytes+ , atomicSubFetchNewMBytes+ -- ** Binary+ , atomicAndFetchOldMBytes+ , atomicAndFetchNewMBytes+ , atomicNandFetchOldMBytes+ , atomicNandFetchNewMBytes+ , atomicOrFetchOldMBytes+ , atomicOrFetchNewMBytes+ , atomicXorFetchOldMBytes+ , atomicXorFetchNewMBytes+ , atomicNotFetchOldMBytes+ , atomicNotFetchNewMBytes+ -- * Prefetch+ , prefetchBytes0+ , prefetchMBytes0+ , prefetchBytes1+ , prefetchMBytes1+ , prefetchBytes2+ , prefetchMBytes2+ , prefetchBytes3+ , prefetchMBytes3+ , module Data.Prim+ -- * Helpers+ ) where++import Control.Monad.ST+import Control.Prim.Monad+import Data.Maybe (fromMaybe)+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`+toByteArray# :: Bytes p -> ByteArray#+toByteArray# (Bytes b#) = b#++-- | Unwrap `Bytes` to get the underlying `ByteArray#`.+fromByteArray# :: ByteArray# -> Bytes 'Inc+fromByteArray# = Bytes++-- | Wrap `MutableByteArray#` into `MBytes`+toMutableByteArray# :: MBytes p s -> MutableByteArray# s+toMutableByteArray# (MBytes mb#) = mb#++-- | Unwrap `MBytes` to get the underlying `MutableByteArray#`.+fromMutableByteArray# :: MutableByteArray# s -> MBytes 'Inc s+fromMutableByteArray# = MBytes+++++-- | Check if two mutable bytes pointers refer to the same memory+isSameMBytes :: MBytes p1 s -> MBytes p2 s -> Bool+isSameMBytes (MBytes mb1#) (MBytes mb2#) = isTrue# (sameMutableByteArray# mb1# mb2#)+{-# INLINE isSameMBytes #-}++eqBytes :: Bytes p1 -> Bytes p2 -> Bool+eqBytes b1 b2 = isSameBytes b1 b2 || eqMem b1 b2+{-# INLINE eqBytes #-}++---- 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))+{-# INLINE compareBytes #-}+++-- | This function allows the change of state token. Use with care, because it can allow+-- mutation to escape the `ST` monad.+coerceStateMBytes :: MBytes p s' -> MBytes p s+coerceStateMBytes = unsafeCoerce#+++emptyBytes :: Bytes p+emptyBytes = castPinnedBytes $ runST $ allocPinnedMBytes (0 :: Count Word8) >>= freezeMBytes+{-# INLINE emptyBytes #-}++isEmptyBytes :: Bytes p -> Bool+isEmptyBytes b = byteCountBytes b == 0+{-# INLINE isEmptyBytes #-}++singletonBytes :: forall e p. (Prim e, Typeable p) => e -> Bytes p+singletonBytes a = runST $ singletonMBytes a >>= freezeMBytes+{-# INLINE singletonBytes #-}++---- Mutable++singletonMBytes :: forall e p m s. (Prim e, Typeable p, MonadPrim s m) => e -> m (MBytes p s)+singletonMBytes a = do+ mb <- allocMBytes (1 :: Count e)+ mb <$ writeOffMBytes mb 0 a+{-# INLINE singletonMBytes #-}++cloneBytes :: Typeable p => Bytes p -> Bytes p+cloneBytes b = runST $ thawBytes b >>= cloneMBytes >>= freezeMBytes+{-# INLINE cloneBytes #-}++cloneMBytes :: (MonadPrim s m, Typeable p) => MBytes p s -> m (MBytes p s)+cloneMBytes mb = do+ n <- getCountMBytes mb+ mb' <- allocMBytes (n :: Count Word8)+ mb' <$ moveMBytesToMBytes mb 0 mb' 0 n+{-# INLINE cloneMBytes #-}+++copyBytesToMBytes ::+ (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)+{-# 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))+{-# INLINE moveMBytesToMBytes #-}++-- | Allocated memory is not cleared, so make sure to fill it in properly, otherwise you+-- might find some garbage there.+createBytes ::+ forall p e b s m. (Prim e, Typeable p, MonadPrim s m)+ => Count e+ -> (MBytes p s -> m b)+ -> m (b, Bytes p)+createBytes n f = do+ mb <- allocMBytes n+ !res <- f mb+ (,) res <$> freezeMBytes mb+{-# INLINE createBytes #-}++createBytes_ ::+ forall p e b s m. (Prim e, Typeable p, MonadPrim s m)+ => Count e+ -> (MBytes p s -> m b)+ -> m (Bytes p)+createBytes_ n f = allocMBytes n >>= \mb -> f mb >> freezeMBytes mb+{-# INLINE createBytes_ #-}++createBytesST ::+ forall p e b. (Prim e, Typeable p)+ => Count e+ -> (forall s . MBytes p s -> ST s b)+ -> (b, Bytes p)+createBytesST n f = runST $ createBytes n f+{-# INLINE createBytesST #-}++createBytesST_ ::+ forall p e b. (Prim e, Typeable p)+ => Count e+ -> (forall s. MBytes p s -> ST s b)+ -> Bytes p+createBytesST_ n f = runST $ createBytes_ n f+{-# INLINE createBytesST_ #-}++callocMBytes :: (MonadPrim s m, Prim e, Typeable p) => Count e -> m (MBytes p s)+callocMBytes n = allocMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0+{-# INLINE callocMBytes #-}++++-- | Fill the mutable array with zeros efficiently.+zeroMBytes :: MonadPrim s m => MBytes p s -> m ()+zeroMBytes mba@(MBytes mba#) = do+ Count (I# n#) <- getByteCountMBytes mba+ prim_ (setByteArray# mba# 0# n# 0#)+{-# INLINE zeroMBytes #-}+++withCloneMBytes ::+ (MonadPrim s m, Typeable p)+ => Bytes p+ -> (MBytes p s -> m a)+ -> m (a, Bytes p)+withCloneMBytes b f = do+ mb <- cloneMBytes =<< thawBytes b+ !res <- f mb+ b' <- freezeMBytes mb+ pure (res, b')+{-# INLINE withCloneMBytes #-}++withCloneMBytes_ ::+ (MonadPrim s m, Typeable p)+ => Bytes p+ -> (MBytes p s -> m a)+ -> m (Bytes p)+withCloneMBytes_ b f = thawBytes b >>= cloneMBytes >>= \mb -> f mb >> freezeMBytes mb+{-# INLINE withCloneMBytes_ #-}++withCloneMBytesST ::+ Typeable p => Bytes p -> (forall s. MBytes p s -> ST s a) -> (a, Bytes p)+withCloneMBytesST b f = runST $ withCloneMBytes b f+{-# INLINE withCloneMBytesST #-}++withCloneMBytesST_ ::+ Typeable p => Bytes p -> (forall s. MBytes p s -> ST s a) -> Bytes p+withCloneMBytesST_ b f = runST $ withCloneMBytes_ b f+{-# INLINE withCloneMBytesST_ #-}+++++-- | Get the count of elements of type @a@ that can fit into bytes as well as the slack+-- number of bytes that would be leftover in case when total number of bytes available is+-- not exactly divisable by the size of the element that will be stored in the memory+-- chunk.+countRemBytes :: forall e p. Prim e => Bytes p -> (Count e, Count Word8)+countRemBytes = fromByteCountRem . byteCountBytes+{-# INLINE countRemBytes #-}++++-- | Get the number of elements of type @a@ that can fit into bytes as well as the slack+-- number of bytes that would be leftover in case when total number of bytes available is+-- not exactly divisable by the size of the element that will be stored in the memory+-- chunk.+getCountRemOfMBytes ::+ forall e p s m. (MonadPrim s m, Prim e)+ => MBytes p s+ -> m (Count e, Count Word8)+getCountRemOfMBytes b = fromByteCountRem <$> getByteCountMBytes b+{-# INLINE getCountRemOfMBytes #-}++-- | 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.+toListBytes :: Prim e => Bytes p -> [e]+toListBytes = toListMem+{-# INLINE toListBytes #-}++toListSlackBytes :: Prim e => Bytes p -> ([e], [Word8])+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+{-# 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+{-# INLINE loadListMBytes_ #-}++fromListBytesN_ :: (Prim e, Typeable p) => Count e -> [e] -> Bytes p+fromListBytesN_ = fromListMemN_+{-# 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`.+fromListBytesN ::+ (Prim e, Typeable p)+ => Count e+ -> [e]+ -> (Ordering, Bytes p)+fromListBytesN = fromListMemN+{-# INLINE fromListBytesN #-}++fromListBytes ::+ forall e p. (Prim e, Typeable p)+ => [e]+ -> Bytes p+fromListBytes = fromListMem+{-# INLINE fromListBytes #-}++-- | Allocate new memory region and append second bytes region after the first one+appendBytes ::+ Typeable p+ => Bytes p1 -- ^ First memory region+ -> Bytes p2 -- ^ Second memory region+ -> Bytes p+appendBytes = appendMem+{-# INLINE appendBytes #-}+++concatBytes :: Typeable p => [Bytes p'] -> Bytes p+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 #-}++ensurePinnedMBytes :: MonadPrim s m => MBytes p s -> m (MBytes 'Pin s)+ensurePinnedMBytes mb =+ case toPinnedMBytes mb of+ Just pmb -> pure pmb+ Nothing -> do+ n8 :: Count Word8 <- getCountMBytes mb+ pmb <- allocPinnedMBytes n8+ pmb <$ moveMBytesToMBytes mb 0 pmb 0 n8+{-# INLINE ensurePinnedMBytes #-}++toPinnedBytes :: Bytes p -> Maybe (Bytes 'Pin)+toPinnedBytes (Bytes b#)+ | isTrue# (isByteArrayPinned# b#) = Just (Bytes b#)+ | otherwise = Nothing+{-# INLINE toPinnedBytes #-}++toPinnedMBytes :: MBytes p s -> Maybe (MBytes 'Pin s)+toPinnedMBytes (MBytes mb#)+ | isTrue# (isMutableByteArrayPinned# mb#) = Just (MBytes mb#)+ | otherwise = Nothing+{-# INLINE toPinnedMBytes #-}++++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Returns the actual value. Offset is in number of elements,+-- rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m e+casMBytes (MBytes mba#) (Off (I# i#)) expected new = prim $ casMutableByteArray# mba# i# expected new+{-# INLINE casMBytes #-}+++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Returns `True` if swap was successfull and false otherwise. Offset is in number+-- of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casBoolMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m Bool+casBoolMBytes (MBytes mba#) (Off (I# i#)) expected new =+ prim $ casBoolMutableByteArray# mba# i# expected new+{-# INLINE casBoolMBytes #-}++-- | Just like `casBoolMBytes`, but also returns the actual value, which will match the+-- supplied expected value if the returned flag is `True`+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+casBoolFetchMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> e -- ^ Expected old value+ -> e -- ^ New value+ -> m (Bool, e)+casBoolFetchMBytes mb off expected new = do+ isCasSucc <- casBoolMBytes mb off expected new+ actual <-+ if isCasSucc+ then pure new+ else readOffMBytes mb off+ pure (isCasSucc, actual)+{-# INLINE casBoolFetchMBytes #-}+++-- | Perform atomic read of `MBytes` at the supplied index. Offset is in number of+-- elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicReadMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> m e+atomicReadMBytes (MBytes mba#) (Off (I# i#)) =+ prim $ atomicReadMutableByteArray# mba# i#+{-# INLINE atomicReadMBytes #-}+++-- | Perform a write into `MBytes` at the supplied index atomically. Offset is in number+-- of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicWriteMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> e+ -> m ()+atomicWriteMBytes (MBytes mba#) (Off (I# i#)) e =+ prim_ $ atomicWriteMutableByteArray# mba# i# e+{-# INLINE atomicWriteMBytes #-}+++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Returns the artifact of computation @__b__@. Offset is in number of elements,+-- rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> (e -> (e, b)) -- ^ Function that is applied to the old value and returns new value+ -- and some artifact of computation @__b__@+ -> m b+atomicModifyMBytes (MBytes mba#) (Off (I# i#)) f =+ prim $+ atomicModifyMutableByteArray# mba# i# $ \a ->+ case f a of+ (a', b) -> (# a', b #)+{-# INLINE atomicModifyMBytes #-}++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Offset is in number of elements, rather than bytes. Implies a full memory+-- barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyMBytes_ ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the old value and returns new value.+ -> m ()+atomicModifyMBytes_ (MBytes mba#) (Off (I# i#)) f =+ prim_ $ atomicModifyMutableByteArray_# mba# i# f+{-# INLINE atomicModifyMBytes_ #-}+++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Returns the previous value. Offset is in number of elements, rather than+-- bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyFetchOldMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the old value and returns the new value+ -> m e+atomicModifyFetchOldMBytes (MBytes mba#) (Off (I# i#)) f =+ prim $ atomicModifyFetchOldMutableByteArray# mba# i# f+{-# INLINE atomicModifyFetchOldMBytes #-}+++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Returns the previous value. Offset is in number of elements, rather than+-- bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicBoolModifyFetchOldMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the old value and returns the new value+ -> m e+atomicBoolModifyFetchOldMBytes (MBytes mba#) (Off (I# i#)) f =+ prim $ atomicBoolModifyFetchOldMutableByteArray# mba# i# f+{-# INLINE atomicBoolModifyFetchOldMBytes #-}+++-- | Perform atomic modification of an element in the `MBytes` at the supplied+-- index. Offset is in number of elements, rather than bytes. Implies a full memory+-- barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicModifyFetchNewMBytes ::+ (MonadPrim s m, Atomic e)+ => MBytes p s -- ^ Array to be mutated+ -> Off e -- ^ Index is in elements of @__a__@, rather than bytes.+ -> (e -> e) -- ^ Function that is applied to the old value and returns the new value+ -> m e+atomicModifyFetchNewMBytes (MBytes mba#) (Off (I# i#)) f =+ prim $ atomicModifyFetchNewMutableByteArray# mba# i# f+{-# INLINE atomicModifyFetchNewMBytes #-}+++++++-- | Add a numeric value to an element of a `MBytes`, corresponds to @(`+`)@ done+-- atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAddFetchOldMBytes ::+ (MonadPrim s m, AtomicCount e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicAddFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicAddFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicAddFetchOldMBytes #-}++-- | Add a numeric value to an element of a `MBytes`, corresponds to @(`+`)@ done+-- atomically. Returns the new value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAddFetchNewMBytes ::+ (MonadPrim s m, AtomicCount e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicAddFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicAddFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicAddFetchNewMBytes #-}++++-- | Subtract a numeric value from an element of a `MBytes`, corresponds to+-- @(`-`)@ done atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicSubFetchOldMBytes ::+ (MonadPrim s m, AtomicCount e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicSubFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicSubFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicSubFetchOldMBytes #-}++-- | Subtract a numeric value from an element of a `MBytes`, corresponds to+-- @(`-`)@ done atomically. Returns the new value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicSubFetchNewMBytes ::+ (MonadPrim s m, AtomicCount e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicSubFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicSubFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicSubFetchNewMBytes #-}++++-- | Binary conjunction (AND) of an element of a `MBytes` with the supplied value,+-- corresponds to @(`Data.Bits..&.`)@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAndFetchOldMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicAndFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicAndFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicAndFetchOldMBytes #-}++-- | Binary conjunction (AND) of an element of a `MBytes` with the supplied value,+-- corresponds to @(`Data.Bits..&.`)@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicAndFetchNewMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicAndFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicAndFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicAndFetchNewMBytes #-}++++-- | Negation of binary conjunction (NAND) of an element of a `MBytes` with the+-- supplied value, corresponds to @\\x y -> `Data.Bits.complement` (x `Data.Bits..&.` y)@+-- done atomically. Returns the previous value. Offset is in number of elements, rather+-- than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNandFetchOldMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicNandFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicNandFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicNandFetchOldMBytes #-}++-- | Negation of binary conjunction (NAND) of an element of a `MBytes` with the supplied+-- value, corresponds to @\\x y -> `Data.Bits.complement` (x `Data.Bits..&.` y)@ done+-- atomically. Returns the new value. Offset is in number of elements, rather than+-- bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNandFetchNewMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicNandFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicNandFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicNandFetchNewMBytes #-}+++++-- | Binary disjunction (OR) of an element of a `MBytes` with the supplied value,+-- corresponds to @(`Data.Bits..|.`)@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicOrFetchOldMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicOrFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicOrFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicOrFetchOldMBytes #-}++-- | Binary disjunction (OR) of an element of a `MBytes` with the supplied value,+-- corresponds to @(`Data.Bits..|.`)@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicOrFetchNewMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicOrFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicOrFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicOrFetchNewMBytes #-}++++-- | Binary exclusive disjunction (XOR) of an element of a `MBytes` with the supplied value,+-- corresponds to @`Data.Bits.xor`@ done atomically. Returns the previous value. Offset+-- is in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicXorFetchOldMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicXorFetchOldMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicXorFetchOldMutableByteArray# mba# i# a)+{-# INLINE atomicXorFetchOldMBytes #-}++-- | Binary exclusive disjunction (XOR) of an element of a `MBytes` with the supplied value,+-- corresponds to @`Data.Bits.xor`@ done atomically. Returns the new value. Offset is+-- in number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicXorFetchNewMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> e+ -> m e+atomicXorFetchNewMBytes (MBytes mba#) (Off (I# i#)) a =+ prim (atomicXorFetchNewMutableByteArray# mba# i# a)+{-# INLINE atomicXorFetchNewMBytes #-}++++++-- | Binary negation (NOT) of an element of a `MBytes`, corresponds to+-- @(`Data.Bits.complement`)@ done atomically. Returns the previous value. Offset is in+-- number of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNotFetchOldMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> m e+atomicNotFetchOldMBytes (MBytes mba#) (Off (I# i#)) =+ prim (atomicNotFetchOldMutableByteArray# mba# i#)+{-# INLINE atomicNotFetchOldMBytes #-}++-- | Binary negation (NOT) of an element of a `MBytes`, corresponds to+-- @(`Data.Bits.complement`)@ done atomically. Returns the new value. Offset is in number+-- of elements, rather than bytes. Implies a full memory barrier.+--+-- /Note/ - Bounds are not checked, therefore this function is unsafe.+--+-- @since 0.1.0+atomicNotFetchNewMBytes ::+ (MonadPrim s m, AtomicBits e)+ => MBytes p s+ -> Off e+ -> m e+atomicNotFetchNewMBytes (MBytes mba#) (Off (I# i#)) =+ prim (atomicNotFetchNewMutableByteArray# mba# i#)+{-# INLINE atomicNotFetchNewMBytes #-}+++++prefetchBytes0 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m ()+prefetchBytes0 (Bytes b#) off = prim_ (prefetchByteArray0# b# (fromOff# off))+{-# INLINE prefetchBytes0 #-}++prefetchMBytes0 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m ()+prefetchMBytes0 (MBytes mb#) off = prim_ (prefetchMutableByteArray0# mb# (fromOff# off))+{-# INLINE prefetchMBytes0 #-}++prefetchBytes1 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m ()+prefetchBytes1 (Bytes b#) off = prim_ (prefetchByteArray1# b# (fromOff# off))+{-# INLINE prefetchBytes1 #-}++prefetchMBytes1 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m ()+prefetchMBytes1 (MBytes mb#) off = prim_ (prefetchMutableByteArray1# mb# (fromOff# off))+{-# INLINE prefetchMBytes1 #-}++prefetchBytes2 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m ()+prefetchBytes2 (Bytes b#) off = prim_ (prefetchByteArray2# b# (fromOff# off))+{-# INLINE prefetchBytes2 #-}++prefetchMBytes2 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m ()+prefetchMBytes2 (MBytes mb#) off = prim_ (prefetchMutableByteArray2# mb# (fromOff# off))+{-# INLINE prefetchMBytes2 #-}++prefetchBytes3 :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> m ()+prefetchBytes3 (Bytes b#) off = prim_ (prefetchByteArray3# b# (fromOff# off))+{-# INLINE prefetchBytes3 #-}++prefetchMBytes3 :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m ()+prefetchMBytes3 (MBytes mb#) off = prim_ (prefetchMutableByteArray3# mb# (fromOff# off))+{-# INLINE prefetchMBytes3 #-}+
+ src/Data/Prim/Memory/Bytes/Internal.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Prim.Memory.Bytes.Internal+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.Bytes.Internal+ ( Bytes(..)+ , MBytes(..)+ , Pinned(..)+ , isSameBytes+ , isSamePinnedBytes+ , isPinnedBytes+ , isPinnedMBytes+ , castPinnedBytes+ , castPinnedMBytes+ , allocMBytes+ , allocPinnedMBytes+ , allocAlignedMBytes+ , allocUnpinnedMBytes+ , callocAlignedMBytes+ , reallocMBytes+ , freezeMBytes+ , thawBytes+ , shrinkMBytes+ , resizeMBytes+ , indexOffBytes+ , indexByteOffBytes+ , compareByteOffBytes+ , byteCountBytes+ , countBytes+ , getCountMBytes+ , getByteCountMBytes+ , setMBytes+ , copyByteOffBytesToMBytes+ , moveByteOffMBytesToMBytes+ , readOffMBytes+ , readByteOffMBytes+ , writeOffMBytes+ , writeByteOffMBytes+ , toPtrBytes+ , toPtrMBytes+ , withPtrBytes+ , withPtrMBytes+ , withNoHaltPtrBytes+ , withNoHaltPtrMBytes+ , toForeignPtrBytes+ , toForeignPtrMBytes+ , fromForeignPtrBytes+ , byteStringConvertError+ ) where++import Control.DeepSeq+import Control.Prim.Monad+import Control.Prim.Monad.Unsafe+import Data.Prim+import Data.Prim.Class+import GHC.ForeignPtr+import Data.Typeable+import Foreign.Prim+++-- | In Haskell there is a distinction between pinned or unpinned memory.+--+-- Pinned memory is such, 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.+--+-- 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+-- that fact through out the "primal" universe there is a distinction between memory that+-- is either @`Pin`ned@ or @`Inc`onclusive@.+--+-- It is possible to use one of `Data.Prim.Memory.Bytes.toPinnedBytes` or+-- `Data.Prim.Memory.Bytes.toPinnedMBytes` to get a conclusive type.+--+-- @since 0.1.0+data Pinned = Pin | Inc++-- | 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.+data Bytes (p :: Pinned) = Bytes ByteArray#+type role Bytes nominal++-- | Mutable 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.fromMutableByteArray#` and+-- unwrapper `Data.Prim.Memory.Bytes.toMutableByteArray#` should be used instead. As a+-- backdoor, of course, the actual constructor is available in "Data.Prim.Memory.Internal"+-- module and specially unsafe function `castPinnedMBytes` was crafted.+data MBytes (p :: Pinned) s = MBytes (MutableByteArray# s)+type role MBytes nominal nominal+++instance NFData (Bytes p) where+ rnf (Bytes _) = ()++instance NFData (MBytes p s) where+ rnf (MBytes _) = ()++++---- Pure++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))+{-# INLINE compareByteOffBytes #-}++indexOffBytes :: Prim e => Bytes p -> Off e -> e+indexOffBytes (Bytes ba#) (Off (I# i#)) = indexByteArray# ba# i#+{-# INLINE indexOffBytes #-}++indexByteOffBytes :: Prim e => Bytes p -> Off Word8 -> e+indexByteOffBytes (Bytes ba#) (Off (I# i#)) = indexByteOffByteArray# ba# i#+{-# INLINE indexByteOffBytes #-}+++---- Mutable+++allocMBytes ::+ forall p e s m. (Typeable p, Prim e, MonadPrim s m)+ => Count e+ -> m (MBytes p s)+allocMBytes c =+ case eqT :: Maybe (p :~: 'Pin) of+ Just Refl -> allocPinnedMBytes c+ _ ->+ case eqT :: Maybe (p :~: 'Inc) of+ Just Refl -> allocUnpinnedMBytes c+ Nothing ->+ errorImpossible+ "allocMBytes"+ $ "Unexpected 'Pinned' kind: '" ++ showsType (Proxy :: Proxy (Bytes p)) "'."+{-# INLINE[0] allocMBytes #-}+{-# RULES+"allocUnpinnedMBytes" allocMBytes = allocUnpinnedMBytes+"allocPinnedMBytes" allocMBytes = allocPinnedMBytes+ #-}++allocUnpinnedMBytes :: (MonadPrim s m, Prim e) => Count e -> m (MBytes 'Inc s)+allocUnpinnedMBytes c =+ prim $ \s ->+ case newByteArray# (fromCount# c) s of+ (# s', ba# #) -> (# s', MBytes ba# #)+{-# INLINE allocUnpinnedMBytes #-}+++allocPinnedMBytes :: (MonadPrim s m, Prim e) => Count e -> m (MBytes 'Pin s)+allocPinnedMBytes c =+ prim $ \s ->+ case newPinnedByteArray# (fromCount# c) s of+ (# s', ba# #) -> (# s', MBytes ba# #)+{-# INLINE allocPinnedMBytes #-}++allocAlignedMBytes ::+ forall e m s. (MonadPrim s m, Prim e)+ => Count e -- ^ Size in number of bytes+ -> m (MBytes 'Pin s)+allocAlignedMBytes c =+ prim $ \s ->+ case newAlignedPinnedByteArray#+ (fromCount# c)+ (alignment# (proxy# :: Proxy# e))+ s of+ (# s', ba# #) -> (# s', MBytes ba# #)+{-# INLINE allocAlignedMBytes #-}++callocAlignedMBytes ::+ (MonadPrim s m, Prim e)+ => Count e -- ^ Size in number of bytes+ -> m (MBytes 'Pin s)+callocAlignedMBytes n = allocAlignedMBytes n >>= \mb -> mb <$ setMBytes mb 0 (toByteCount n) 0+{-# INLINE callocAlignedMBytes #-}+++getByteCountMBytes :: MonadPrim s m => MBytes p s -> m (Count Word8)+getByteCountMBytes (MBytes mba#) =+ prim $ \s ->+ case getSizeofMutableByteArray# mba# s of+ (# s', n# #) -> (# s', Count (I# n#) #)+{-# INLINE getByteCountMBytes #-}++freezeMBytes :: MonadPrim s m => MBytes p s -> m (Bytes p)+freezeMBytes (MBytes mba#) =+ prim $ \s ->+ case unsafeFreezeByteArray# mba# s of+ (# s', ba# #) -> (# s', Bytes ba# #)+{-# INLINE freezeMBytes #-}++thawBytes :: MonadPrim s m => Bytes p -> m (MBytes p s)+thawBytes (Bytes ba#) =+ prim $ \s ->+ case unsafeThawByteArray# ba# s of+ (# s', mba# #) -> (# s', MBytes mba# #)+{-# INLINE thawBytes #-}++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)+{-# 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))+{-# INLINE moveByteOffMBytesToMBytes #-}+++byteCountBytes :: Bytes p -> Count Word8+byteCountBytes (Bytes ba#) = coerce (I# (sizeofByteArray# ba#))+{-# INLINE byteCountBytes #-}+++-- | 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))+{-# INLINE shrinkMBytes #-}+++-- | 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+resizeMBytes ::+ (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+ (# s', mb'# #) -> (# s', MBytes mb'# #)+{-# INLINE resizeMBytes #-}++reallocMBytes ::+ forall e p m s. (MonadPrim s m, Typeable p, Prim e)+ => MBytes p s+ -> Count e+ -> m (MBytes p s)+reallocMBytes mb c = do+ oldByteCount <- getByteCountMBytes mb+ let newByteCount = toByteCount c+ if newByteCount <= oldByteCount+ then mb <$ when (newByteCount < oldByteCount) (shrinkMBytes mb newByteCount)+ else case eqT :: Maybe (p :~: 'Pin) of+ Just Refl -> do+ b <- freezeMBytes mb+ mb' <- allocPinnedMBytes newByteCount+ mb' <$ copyByteOffBytesToMBytes b 0 mb' 0 oldByteCount+ Nothing -> castPinnedMBytes <$> resizeMBytes mb newByteCount+{-# INLINABLE reallocMBytes #-}++castPinnedBytes :: Bytes p' -> Bytes p+castPinnedBytes (Bytes b#) = Bytes b#++castPinnedMBytes :: MBytes p' s -> MBytes p s+castPinnedMBytes (MBytes b#) = MBytes b#++-- | 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+countBytes = fromByteCount . byteCountBytes+{-# INLINE countBytes #-}++-- | How many elements of type @a@ fits into bytes completely. In order to get any number+-- of leftover bytes use `countRemBytes`+getCountMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> m (Count e)+getCountMBytes b = fromByteCount <$> getByteCountMBytes b+{-# INLINE getCountMBytes #-}++readOffMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> m e+readOffMBytes (MBytes mba#) (Off (I# i#)) = prim (readMutableByteArray# mba# i#)+{-# INLINE readOffMBytes #-}++readByteOffMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> Off Word8 -> m e+readByteOffMBytes (MBytes mba#) (Off (I# i#)) = prim (readByteOffMutableByteArray# mba# i#)+{-# INLINE readByteOffMBytes #-}++writeOffMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> e -> m ()+writeOffMBytes (MBytes mba#) (Off (I# i#)) a = prim_ (writeMutableByteArray# mba# i# a)+{-# INLINE writeOffMBytes #-}++writeByteOffMBytes :: (MonadPrim s m, Prim e) => MBytes p s -> Off Word8 -> e -> m ()+writeByteOffMBytes (MBytes mba#) (Off (I# i#)) a = prim_ (writeByteOffMutableByteArray# mba# i# a)+{-# INLINE writeByteOffMBytes #-}++isPinnedBytes :: Bytes p -> Bool+isPinnedBytes (Bytes b#) = isTrue# (isByteArrayPinned# b#)+{-# INLINE[0] isPinnedBytes #-}++isPinnedMBytes :: MBytes p d -> Bool+isPinnedMBytes (MBytes mb#) = isTrue# (isMutableByteArrayPinned# mb#)+{-# INLINE[0] isPinnedMBytes #-}++{-# RULES+"isPinnedBytes" forall (x :: Bytes 'Pin) . isPinnedBytes x = True+"isPinnedMBytes" forall (x :: MBytes 'Pin s) . isPinnedMBytes x = True+ #-}++++setMBytes ::+ (MonadPrim s m, Prim e)+ => MBytes p s -- ^ Chunk of memory to fill+ -> Off e -- ^ Offset in number of elements+ -> Count e -- ^ Number of cells to fill+ -> e -- ^ A value to fill the cells with+ -> m ()+setMBytes (MBytes mba#) (Off (I# o#)) (Count (I# n#)) a = prim_ (setMutableByteArray# mba# o# n# a)+{-# INLINE setMBytes #-}+++toPtrBytes :: Bytes 'Pin -> Ptr e+toPtrBytes (Bytes ba#) = Ptr (byteArrayContents# ba#)+{-# INLINE toPtrBytes #-}++toPtrMBytes :: MBytes 'Pin s -> Ptr e+toPtrMBytes (MBytes mba#) = Ptr (mutableByteArrayContents# mba#)+{-# INLINE toPtrMBytes #-}++-- | Pointer access to immutable `Bytes` should be for read only purposes, but it is+-- not enforced. Any mutation will break referential transparency+withPtrBytes :: MonadPrim s m => Bytes 'Pin -> (Ptr e -> m b) -> m b+withPtrBytes b f = do+ res <- f (toPtrBytes b)+ res <$ touch b+{-# INLINE withPtrBytes #-}++-- | Same as `withPtrBytes`, but is suitable for actions that don't terminate+withNoHaltPtrBytes :: MonadUnliftPrim s m => Bytes 'Pin -> (Ptr e -> m b) -> m b+withNoHaltPtrBytes b f = withAliveUnliftPrim b $ f (toPtrBytes b)+{-# INLINE withNoHaltPtrBytes #-}++withPtrMBytes :: MonadPrim s m => MBytes 'Pin s -> (Ptr e -> m b) -> m b+withPtrMBytes mb f = do+ res <- f (toPtrMBytes mb)+ res <$ touch mb+{-# INLINE withPtrMBytes #-}++withNoHaltPtrMBytes :: MonadUnliftPrim s m => MBytes 'Pin s -> (Ptr e -> m b) -> m b+withNoHaltPtrMBytes mb f = withAliveUnliftPrim mb $ f (toPtrMBytes mb)+{-# INLINE withNoHaltPtrMBytes #-}++toForeignPtrBytes :: Bytes 'Pin -> ForeignPtr e+toForeignPtrBytes (Bytes ba#) =+ ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#))+{-# INLINE toForeignPtrBytes #-}+++toForeignPtrMBytes :: MBytes 'Pin s -> ForeignPtr e+toForeignPtrMBytes (MBytes mba#) =+ ForeignPtr (byteArrayContents# (unsafeCoerce# 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"+ 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 #-}+++-- | Check if two byte arrays refer to pinned memory and compare their pointers.+isSameBytes :: Bytes p1 -> Bytes p2 -> Bool+isSameBytes (Bytes b1#) (Bytes b2#) = isTrue# (isSameByteArray# b1# b2#)+{-# INLINE[0] isSameBytes #-}+{-# RULES+"isSamePinnedBytes" isSameBytes = isSamePinnedBytes+ #-}++-- | Perform pointer equality on pinned `Bytes`.+isSamePinnedBytes :: Bytes 'Pin -> Bytes 'Pin -> Bool+isSamePinnedBytes pb1 pb2 = toPtrBytes pb1 == toPtrBytes pb2+{-# INLINE isSamePinnedBytes #-}++++byteStringConvertError :: String -> a+byteStringConvertError msg = error $ "Cannot convert 'ByteString'. " ++ msg+{-# NOINLINE byteStringConvertError #-}+
+ src/Data/Prim/Memory/ForeignPtr.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Prim.Bytes.ForeignPtr+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.ForeignPtr+ ( PtrAccess(..)+ -- * ForeignPtr+ , ForeignPtr(..)+ , castForeignPtr+ , unsafeForeignPtrToPtr+ , ForeignPtrContents(..)+ -- * Pointer arithmetic+ , plusOffForeignPtr+ , plusByteOffForeignPtr+ , minusOffForeignPtr+ , minusOffRemForeignPtr+ , minusByteOffForeignPtr+ , withForeignPtr+ , withNoHaltForeignPtr+ -- ** PlainPtr+ , mallocPlainForeignPtr+ , mallocCountPlainForeignPtr+ , mallocCountPlainForeignPtrAligned+ , mallocByteCountPlainForeignPtr+ , mallocByteCountPlainForeignPtrAligned+ -- ** With Finalizers+ , finalizeForeignPtr+ -- *** Foreign finalizer+ , FinalizerPtr+ , newForeignPtr+ , newForeignPtr_+ , touchForeignPtr+ , mallocForeignPtr+ , mallocCountForeignPtr+ , mallocCountForeignPtrAligned+ , mallocByteCountForeignPtr+ , mallocByteCountForeignPtrAligned+ , addForeignPtrFinalizer+ -- *** With environment+ , FinalizerEnvPtr+ , newForeignPtrEnv+ , addForeignPtrFinalizerEnv+ -- *** Haskell finalizer+ , newConcForeignPtr+ , addForeignPtrConcFinalizer+ -- * Conversion+ -- ** Bytes+ , toForeignPtrBytes+ , 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 qualified Foreign.ForeignPtr as GHC+import qualified GHC.ForeignPtr as GHC+++-- | For memory allocated as pinned it is possible to operate on it with a `Ptr`. Any data+-- type that is backed by such memory can have a `PtrAccess` instance. The simplest way is+-- to convert it to a `ForeignPtr` and other functions will come for free.+class PtrAccess s p where+ -- | Convert to `ForeignPtr`.+ toForeignPtr :: MonadPrim s m => p -> m (ForeignPtr a)++ -- | Apply an action to the raw memory `Ptr` to which the data type point to. Type of data+ -- stored in memory is left ambiguous intentionaly, so that the user can choose how to+ -- treat the memory content.+ withPtrAccess :: MonadPrim s m => p -> (Ptr a -> m b) -> m b+ withPtrAccess p action = toForeignPtr p >>= (`withForeignPtr` action)+ {-# INLINE withPtrAccess #-}++ -- | See this GHC <https://gitlab.haskell.org/ghc/ghc/issues/18061 issue #18061> 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#)+ {-# INLINE withNoHaltPtrAccess #-}++instance PtrAccess s (ForeignPtr a) where+ toForeignPtr = pure . coerce+ {-# INLINE toForeignPtr #-}++-- | Read-only access, but it is not enforced.+instance PtrAccess s ByteString where+ toForeignPtr (PS ps s _) = pure (coerce ps `plusByteOffForeignPtr` Off s)+ {-# INLINE toForeignPtr #-}+ withPtrAccess = withPtrByteString+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess = withNoHaltPtrByteString+ {-# INLINE withNoHaltPtrAccess #-}++instance PtrAccess s (MByteString s) where+ toForeignPtr mbs = toForeignPtr (coerce mbs :: ByteString)+ {-# INLINE toForeignPtr #-}+ withPtrAccess mbs = withPtrByteString (coerce mbs)+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess mbs = withNoHaltPtrByteString (coerce mbs)+ {-# INLINE withNoHaltPtrAccess #-}++-- | Read-only access, but it is not enforced.+instance PtrAccess s (Bytes 'Pin) where+ toForeignPtr = pure . toForeignPtrBytes+ {-# INLINE toForeignPtr #-}+ withPtrAccess = withPtrBytes+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess = withNoHaltPtrBytes+ {-# INLINE withNoHaltPtrAccess #-}++instance PtrAccess s (MBytes 'Pin s) where+ toForeignPtr = pure . toForeignPtrMBytes+ {-# INLINE toForeignPtr #-}+ withPtrAccess = withPtrMBytes+ {-# INLINE withPtrAccess #-}+ withNoHaltPtrAccess = withNoHaltPtrMBytes+ {-# INLINE withNoHaltPtrAccess #-}+++-- | Apply an action to the raw pointer. It is unsafe to return the actual pointer back from+-- the action because memory itself might get garbage collected or cleaned up by+-- finalizers.+--+-- It is also important not to run non-terminating actions, because GHC can optimize away+-- the logic that runs after the action and GC will happen before the action get's a chance+-- to finish resulting in corrupt memory. Whenever you have an action that runs an infinite+-- loop or ends in an exception throwing, make sure to use `withNoHaltForeignPtr` instead.+withForeignPtr :: MonadPrim s m => ForeignPtr e -> (Ptr e -> m b) -> m b+withForeignPtr (ForeignPtr addr# ptrContents) f = do+ r <- f (Ptr addr#)+ r <$ touch ptrContents+{-# INLINE withForeignPtr #-}++-- | Same thing as `withForeignPtr` except it should be used for never ending actions. See+-- `withNoHaltPtrAccess` for more information on how this differes from `withForeignPtr`.+--+-- @since 0.1.0+withNoHaltForeignPtr ::+ MonadUnliftPrim s m => ForeignPtr e -> (Ptr e -> m b) -> m b+withNoHaltForeignPtr (ForeignPtr addr# ptrContents) f =+ withAliveUnliftPrim ptrContents $ f (Ptr addr#)+{-# INLINE withNoHaltForeignPtr #-}++-- | Lifted version of `GHC.touchForeignPtr`.+touchForeignPtr :: MonadPrim s m => ForeignPtr e -> m ()+touchForeignPtr (ForeignPtr _ contents) = touch contents++-- | Lifted version of `GHC.newForeignPtr`.+newForeignPtr :: MonadPrim RW m => FinalizerPtr e -> Ptr e -> m (ForeignPtr e)+newForeignPtr fin = liftPrimBase . GHC.newForeignPtr fin++-- | Lifted version of `GHC.newForeignPtrEnv`.+newForeignPtrEnv :: MonadPrim RW m => FinalizerEnvPtr env e -> Ptr env -> Ptr e -> m (ForeignPtr e)+newForeignPtrEnv finEnv envPtr = liftPrimBase . GHC.newForeignPtrEnv finEnv envPtr+++-- | Lifted version of `GHC.newForeignPtr_`.+newForeignPtr_ :: MonadPrim RW m => Ptr e -> m (ForeignPtr e)+newForeignPtr_ = liftPrimBase . GHC.newForeignPtr_++-- | Simila to `GHC.mallocForeignPtr`, except it operates on `Prim`, instead of `Storable`.+mallocForeignPtr :: forall e m . (MonadPrim RW m, Prim e) => m (ForeignPtr e)+mallocForeignPtr = mallocCountForeignPtrAligned (1 :: Count e)+++-- | 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++-- | Just like `mallocCountForeignPtr`, but memory is also aligned according to `Prim` instance+mallocCountForeignPtrAligned :: (MonadPrim RW m, Prim e) => Count e -> m (ForeignPtr e)+mallocCountForeignPtrAligned count =+ liftPrimBase $ GHC.mallocForeignPtrAlignedBytes (coerce count) (alignmentProxy count)++-- | Lifted version of `GHC.mallocForeignPtrBytes`.+mallocByteCountForeignPtr :: MonadPrim RW m => Count Word8 -> m (ForeignPtr e)+mallocByteCountForeignPtr = liftPrimBase . GHC.mallocForeignPtrBytes . coerce++-- | Lifted version of `GHC.mallocForeignPtrAlignedBytes`.+mallocByteCountForeignPtrAligned ::+ MonadPrim RW m+ => Count Word8 -- ^ Number of bytes to allocate+ -> Int -- ^ Alignment in bytes+ -> m (ForeignPtr e)+mallocByteCountForeignPtrAligned count =+ liftPrimBase . GHC.mallocForeignPtrAlignedBytes (coerce count)+++-- | Lifted version of `GHC.addForeignPtrFinalizer`+addForeignPtrFinalizer :: MonadPrim RW m => FinalizerPtr e -> ForeignPtr e -> m ()+addForeignPtrFinalizer fin = liftPrimBase . GHC.addForeignPtrFinalizer fin+++-- | Lifted version of `GHC.addForeignPtrFinalizerEnv`+addForeignPtrFinalizerEnv ::+ MonadPrim RW m => FinalizerEnvPtr env e -> Ptr env -> ForeignPtr e -> m ()+addForeignPtrFinalizerEnv fin envPtr = liftPrimBase . GHC.addForeignPtrFinalizerEnv fin envPtr+++-- | Similar to `GHC.mallocPlainForeignPtr`, except instead of `Storable` we use `Prim` and+-- we are not restricted to `IO`, since finalizers are not possible with `PlaintPtr`+mallocPlainForeignPtr ::+ forall e m s. (MonadPrim s m, Prim e)+ => m (ForeignPtr e)+mallocPlainForeignPtr = mallocCountPlainForeignPtr (1 :: Count e)+{-# INLINE mallocPlainForeignPtr #-}++-- | Similar to `Foreign.ForeignPtr.mallocPlainForeignPtrArray`, except instead of `Storable` we+-- use `Prim`.+mallocCountPlainForeignPtr :: (MonadPrim s m, Prim e) => Count e -> m (ForeignPtr e)+mallocCountPlainForeignPtr = mallocByteCountPlainForeignPtr . toByteCount+{-# INLINE mallocCountPlainForeignPtr #-}++-- | Just like `mallocCountForeignPtr`, but memory is also aligned according to `Prim` instance+mallocCountPlainForeignPtrAligned ::+ forall e m s. (MonadPrim s m, Prim e)+ => Count e+ -> m (ForeignPtr e)+mallocCountPlainForeignPtrAligned c =+ prim $ \s ->+ let a# = alignment# (proxy# :: Proxy# e)+ in case newAlignedPinnedByteArray# (fromCount# c) a# s of+ (# s', mba# #) ->+ let addr# = mutableByteArrayContents# mba#+ in (# s', ForeignPtr addr# (PlainPtr (unsafeCoerce# mba#)) #)+{-# INLINE mallocCountPlainForeignPtrAligned #-}++-- | Lifted version of `GHC.mallocForeignPtrBytes`.+mallocByteCountPlainForeignPtr :: MonadPrim s m => Count Word8 -> m (ForeignPtr e)+mallocByteCountPlainForeignPtr (Count (I# c#)) =+ prim $ \s ->+ case newPinnedByteArray# c# s of+ (# s', mba# #) ->+ (# s', ForeignPtr (mutableByteArrayContents# mba#) (PlainPtr (unsafeCoerce# mba#)) #)+{-# INLINE mallocByteCountPlainForeignPtr #-}+++-- | Lifted version of `GHC.mallocForeignPtrAlignedBytes`.+mallocByteCountPlainForeignPtrAligned ::+ MonadPrim s m+ => Count Word8 -- ^ Number of bytes to allocate+ -> Int -- ^ Alignment in bytes+ -> m (ForeignPtr e)+mallocByteCountPlainForeignPtrAligned (Count (I# c#)) (I# a#) =+ prim $ \s ->+ case newAlignedPinnedByteArray# c# a# s of+ (# s', mba# #) ->+ (# s', ForeignPtr (mutableByteArrayContents# mba#) (PlainPtr (unsafeCoerce# mba#)) #)+{-# INLINE mallocByteCountPlainForeignPtrAligned #-}++++-- | Unlifted version of `GHC.newConcForeignPtr`+newConcForeignPtr :: MonadUnliftPrim RW m => Ptr e -> m () -> m (ForeignPtr e)+newConcForeignPtr ptr fin =+ withRunInPrimBase $ \run -> liftPrimBase (GHC.newConcForeignPtr ptr (run fin))+++-- | Unlifted version of `GHC.addForeignPtrConcFinalizer`+addForeignPtrConcFinalizer :: MonadUnliftPrim RW m => ForeignPtr a -> m () -> m ()+addForeignPtrConcFinalizer fp fin =+ withRunInPrimBase $ \run -> liftPrimBase (GHC.addForeignPtrConcFinalizer fp (run fin))++-- | Lifted version of `GHC.finalizeForeignPtr`.+finalizeForeignPtr :: MonadPrim RW m => ForeignPtr e -> m ()+finalizeForeignPtr = liftPrimBase . GHC.finalizeForeignPtr++-- | Advances the given address by the given offset in number of elemeents. This operation+-- does not affect associated finalizers in any way.+--+-- @since 0.1.0+plusOffForeignPtr :: Prim e => ForeignPtr e -> Off e -> ForeignPtr e+plusOffForeignPtr (ForeignPtr addr# content) off =+ ForeignPtr (addr# `plusAddr#` fromOff# off) content+{-# INLINE plusOffForeignPtr #-}+++-- | Advances the given address by the given offset in bytes. This operation does not+-- affect associated finalizers in any way.+--+-- @since 0.1.0+plusByteOffForeignPtr :: ForeignPtr e -> Off Word8 -> ForeignPtr e+plusByteOffForeignPtr (ForeignPtr addr# content) (Off (I# c#)) =+ ForeignPtr (addr# `plusAddr#` c#) content+{-# INLINE plusByteOffForeignPtr #-}++-- | Find the offset in bytes that is between the two pointers by subtracting one address+-- from another.+--+-- @since 0.1.0+minusByteOffForeignPtr :: ForeignPtr e -> ForeignPtr e -> Off Word8+minusByteOffForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =+ Off (I# (xaddr# `minusAddr#` yaddr#))+{-# INLINE minusByteOffForeignPtr #-}++-- | Find the offset in number of elements that is between the two pointers by subtracting+-- one address from another and dividing the result by the size of an element.+--+-- @since 0.1.0+minusOffForeignPtr :: Prim e => ForeignPtr e -> ForeignPtr e -> Off e+minusOffForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =+ fromByteOff (Off (I# (xaddr# `minusAddr#` yaddr#)))+{-# INLINE minusOffForeignPtr #-}++-- | Same as `minusOffForeignPtr`, but will also return the remainder in bytes that is+-- left over.+--+-- @since 0.1.0+minusOffRemForeignPtr :: Prim e => ForeignPtr e -> ForeignPtr e -> (Off e, Off Word8)+minusOffRemForeignPtr (ForeignPtr xaddr# _) (ForeignPtr yaddr# _) =+ fromByteOffRem (Off (I# (xaddr# `minusAddr#` yaddr#)))+{-# INLINE minusOffRemForeignPtr #-}
+ src/Data/Prim/Memory/Internal.hs view
@@ -0,0 +1,980 @@+{-# LANGUAGE BangPatterns #-}+{-# 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 <alexey@kuleshevi.ch>+-- 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)
+ src/Data/Prim/Memory/Ptr.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module : Data.Prim.Memory.Ptr+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Prim.Memory.Ptr+ ( module Foreign.Prim.Ptr++ , copyPtrToMBytes+ , movePtrToMBytes+ , copyBytesToPtr+ , copyMBytesToPtr+ , moveMBytesToPtr+ , copyByteOffPtrToMBytes+ , moveByteOffPtrToMBytes+ , copyByteOffBytesToPtr+ , copyByteOffMBytesToPtr+ , moveByteOffMBytesToPtr+ , compareByteOffBytesToPtr+ , compareByteOffPtrToBytes+ , module Data.Prim+ ) where+++import Control.Prim.Monad+import Control.Prim.Monad.Unsafe+import Data.Prim+import Data.Prim.Memory.Bytes.Internal (Bytes(..), MBytes(..))+import Data.Prim.Class+import Foreign.Prim+import Foreign.Prim.Ptr++++copyPtrToMBytes ::+ (MonadPrim s m, Prim e) => Ptr e -> Off e -> MBytes p s -> Off e -> Count e -> m ()+copyPtrToMBytes src srcOff dst dstOff =+ copyByteOffPtrToMBytes src (toByteOff srcOff) dst (toByteOff dstOff)+{-# INLINE copyPtrToMBytes #-}++++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)+{-# INLINE copyByteOffPtrToMBytes #-}+++copyBytesToPtr :: (MonadPrim s m, Prim e) => Bytes p -> Off e -> Ptr e -> Off e -> Count e -> m ()+copyBytesToPtr src srcOff dst dstOff =+ copyByteOffBytesToPtr src (toByteOff srcOff) dst (toByteOff dstOff)+{-# INLINE copyBytesToPtr #-}+++copyByteOffBytesToPtr ::+ (MonadPrim s m, Prim e)+ => Bytes p+ -> Off Word8+ -> Ptr e+ -> Off Word8+ -> Count e+ -> m ()+copyByteOffBytesToPtr (Bytes src#) (Off (I# srcOff#)) (Ptr dstAddr#) (Off (I# dstOff#)) c =+ prim_ $+ copyByteArrayToAddr#+ src#+ srcOff#+ (dstAddr# `plusAddr#` dstOff#)+ (fromCount# c)+{-# INLINE copyByteOffBytesToPtr #-}+++copyMBytesToPtr :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> Ptr e -> Off e -> Count e -> m ()+copyMBytesToPtr src srcOff dst dstOff =+ copyByteOffMBytesToPtr src (toByteOff srcOff) dst (toByteOff dstOff)+{-# INLINE copyMBytesToPtr #-}+++copyByteOffMBytesToPtr ::+ (MonadPrim s m, Prim e)+ => MBytes p s+ -> Off Word8+ -> Ptr e+ -> Off Word8+ -> Count e+ -> m ()+copyByteOffMBytesToPtr (MBytes src#) (Off (I# srcOff#)) (Ptr dstAddr#) (Off (I# dstOff#)) c =+ prim_ $+ copyMutableByteArrayToAddr#+ src#+ srcOff#+ (dstAddr# `plusAddr#` dstOff#)+ (fromCount# c)+{-# INLINE copyByteOffMBytesToPtr #-}+++movePtrToMBytes :: (MonadPrim s m, Prim e) => Ptr e -> Off e -> MBytes p s -> Off e -> Count e -> m ()+movePtrToMBytes src srcOff dst dstOff =+ moveByteOffPtrToMBytes src (toByteOff srcOff) dst (toByteOff dstOff)+{-# INLINE movePtrToMBytes #-}++moveByteOffPtrToMBytes ::+ (MonadPrim s m, Prim e)+ => Ptr e+ -> Off Word8+ -> MBytes p s+ -> Off Word8+ -> Count e+ -> m ()+moveByteOffPtrToMBytes (Ptr srcAddr#) (Off (I# srcOff#)) (MBytes dst#) (Off (I# dstOff#)) c =+ unsafeIOToPrim $+ memmoveMutableByteArrayFromAddr# srcAddr# srcOff# dst# dstOff# (fromCount# c)+{-# INLINE moveByteOffPtrToMBytes #-}++moveMBytesToPtr :: (MonadPrim s m, Prim e) => MBytes p s -> Off e -> Ptr e -> Off e -> Count e -> m ()+moveMBytesToPtr src srcOff dst dstOff =+ moveByteOffMBytesToPtr src (toByteOff srcOff) dst (toByteOff dstOff)+{-# INLINE moveMBytesToPtr #-}+++moveByteOffMBytesToPtr ::+ (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)+{-# 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))+{-# 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))+{-# INLINE compareByteOffPtrToBytes #-}