diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for primal-memory + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# primal-memory + + +* Bridge the gap between `Storable` and `Prim`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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) + ] diff --git a/bench/Conversion.hs b/bench/Conversion.hs new file mode 100644 --- /dev/null +++ b/bench/Conversion.hs @@ -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 () diff --git a/primal-memory.cabal b/primal-memory.cabal new file mode 100644 --- /dev/null +++ b/primal-memory.cabal @@ -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 +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 diff --git a/src/Data/Prim/Memory.hs b/src/Data/Prim/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory.hs @@ -0,0 +1,89 @@ +-- | +-- Module : Data.Prim.Memory +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- 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. diff --git a/src/Data/Prim/Memory/Addr.hs b/src/Data/Prim/Memory/Addr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Addr.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Prim/Memory/ByteArray.hs b/src/Data/Prim/Memory/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/ByteArray.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Prim.Memory.ByteArray + ( ByteArray(..) + , MByteArray(..) + , Pinned(..) + , fromBytesByteArray + , toBytesByteArray + , castByteArray + , fromMBytesMByteArray + , toMBytesMByteArray + , castMByteArray + , allocMByteArray + , allocPinnedMByteArray + , allocAlignedMByteArray + , allocUnpinnedMByteArray + , shrinkMByteArray + , resizeMByteArray + , reallocMByteArray + , isPinnedByteArray + , isPinnedMByteArray + + , thawByteArray + , freezeMByteArray + , sizeByteArray + , getSizeMByteArray + , readMByteArray + , writeMByteArray + + , setMByteArray + , copyByteArrayToMByteArray + , moveMByteArrayToMByteArray + ) where + +import Control.DeepSeq +import Control.Prim.Monad +import Foreign.Prim +import Data.Prim +import Data.Prim.Memory.Bytes +import Data.Prim.Memory.Internal +import Data.Prim.Memory.ForeignPtr + + +-- | An immutable array of bytes of type @e@ +newtype ByteArray (p :: Pinned) e = ByteArray (Bytes p) + deriving (NFData, Semigroup, Monoid, MemRead) +type role ByteArray nominal nominal + +-- | A mutable array of bytes of type @e@ +newtype MByteArray (p :: Pinned) e s = MByteArray (MBytes p s) + deriving (NFData, MemWrite) +type role MByteArray nominal nominal nominal + +-- | Read-only access, but it is not enforced. +instance PtrAccess s (ByteArray 'Pin e) where + toForeignPtr = pure . toForeignPtrBytes . toBytesByteArray + {-# INLINE toForeignPtr #-} + withPtrAccess b = withPtrBytes (toBytesByteArray b) + {-# INLINE withPtrAccess #-} + withNoHaltPtrAccess b = withNoHaltPtrBytes (toBytesByteArray b) + {-# INLINE withNoHaltPtrAccess #-} + +instance PtrAccess s (MByteArray 'Pin e s) where + toForeignPtr = pure . toForeignPtrMBytes . toMBytesMByteArray + {-# INLINE toForeignPtr #-} + withPtrAccess mb = withPtrMBytes (toMBytesMByteArray mb) + {-# INLINE withPtrAccess #-} + withNoHaltPtrAccess mb = withNoHaltPtrMBytes (toMBytesMByteArray mb) + {-# INLINE withNoHaltPtrAccess #-} + +instance Typeable p => MemAlloc (MByteArray p e) where + type FrozenMem (MByteArray p e) = ByteArray p e + getByteCountMem = getByteCountMem . toMBytesMByteArray + {-# INLINE getByteCountMem #-} + allocByteCountMem = fmap fromMBytesMByteArray . allocMBytes + {-# INLINE allocByteCountMem #-} + thawMem = thawByteArray + {-# INLINE thawMem #-} + freezeMem = freezeMByteArray + {-# INLINE freezeMem #-} + resizeMem mba = fmap fromMBytesMByteArray . reallocMBytes (toMBytesMByteArray mba) + {-# INLINE resizeMem #-} + +instance (Typeable p, Prim e) => IsList (ByteArray p e) where + type Item (ByteArray p e) = e + fromList = fromListMem + fromListN n = fromListMemN_ (Count n) + toList = toListMem + +instance Typeable p => IsString (ByteArray p Char) where + fromString = fromListMem + +instance (Show e, Prim e) => Show (ByteArray p e) where + show = show . toListByteArray + + +toListByteArray :: Prim e => ByteArray p e -> [e] +toListByteArray = toListMem + +castByteArray :: ByteArray p e' -> ByteArray p e +castByteArray = coerce + +fromBytesByteArray :: Bytes p -> ByteArray p e +fromBytesByteArray = coerce + +toBytesByteArray :: ByteArray p e -> Bytes p +toBytesByteArray = coerce + +castMByteArray :: MByteArray p e' s -> MByteArray p e s +castMByteArray = coerce + +fromMBytesMByteArray :: MBytes p s -> MByteArray p e s +fromMBytesMByteArray = coerce + +toMBytesMByteArray :: MByteArray p e s -> MBytes p s +toMBytesMByteArray = coerce + +sizeByteArray :: forall e p. Prim e => ByteArray p e -> Size +sizeByteArray = (coerce :: Count e -> Size) . countBytes . toBytesByteArray +{-# INLINE sizeByteArray #-} + +getSizeMByteArray :: forall e p m s. (MonadPrim s m, Prim e) => MByteArray p e s -> m Size +getSizeMByteArray = fmap (coerce :: Count e -> Size) . getCountMBytes . toMBytesMByteArray +{-# INLINE getSizeMByteArray #-} + +allocMByteArray :: + forall e p m s . (Typeable p, Prim e, MonadPrim s m) => Size -> m (MByteArray p e s) +allocMByteArray sz = fromMBytesMByteArray <$> allocMBytes (coerce sz :: Count e) +{-# INLINE allocMByteArray #-} + +allocUnpinnedMByteArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MByteArray 'Inc e s) +allocUnpinnedMByteArray sz = fromMBytesMByteArray <$> allocUnpinnedMBytes (coerce sz :: Count e) +{-# INLINE allocUnpinnedMByteArray #-} + +allocPinnedMByteArray :: forall e m s . (MonadPrim s m, Prim e) => Size -> m (MByteArray 'Pin e s) +allocPinnedMByteArray sz = fromMBytesMByteArray <$> allocPinnedMBytes (coerce sz :: Count e) +{-# INLINE allocPinnedMByteArray #-} + +allocAlignedMByteArray :: + (MonadPrim s m, Prim e) + => Count e -- ^ Size in number of bytes + -> m (MByteArray 'Pin e s) +allocAlignedMByteArray = fmap fromMBytesMByteArray . allocAlignedMBytes +{-# INLINE allocAlignedMByteArray #-} + +freezeMByteArray :: MonadPrim s m => MByteArray p e s -> m (ByteArray p e) +freezeMByteArray = fmap fromBytesByteArray . freezeMBytes . toMBytesMByteArray +{-# INLINE freezeMByteArray #-} + +thawByteArray :: MonadPrim s m => ByteArray p e -> m (MByteArray p e s) +thawByteArray = fmap fromMBytesMByteArray . thawBytes . toBytesByteArray +{-# INLINE thawByteArray #-} + +-- | Shrink mutable bytes to new specified count of elements. The new count must be less +-- than or equal to the current count as reported by `getCountMByteArray`. +shrinkMByteArray :: + forall e p m s. (MonadPrim s m, Prim e) + => MByteArray p e s + -> Size + -> m () +shrinkMByteArray mba sz = shrinkMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) +{-# INLINE shrinkMByteArray #-} + + +-- | Attempt to resize mutable bytes in place. +-- +-- * New bytes might be allocated, with the copy of an old one. +-- * Old references should not be kept around to allow GC to claim it +-- * Old references should not be used to avoid undefined behavior +resizeMByteArray :: + forall e p m s. (MonadPrim s m, Prim e) + => MByteArray p e s + -> Size + -> m (MByteArray 'Inc e s) +resizeMByteArray mba sz = + fromMBytesMByteArray <$> + resizeMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) +{-# INLINE resizeMByteArray #-} + +reallocMByteArray :: + forall e p m s. (MonadPrim s m, Typeable p, Prim e) + => MByteArray p e s + -> Size + -> m (MByteArray p e s) +reallocMByteArray mba sz = + fromMBytesMByteArray <$> + reallocMBytes (toMBytesMByteArray mba) (coerce sz :: Count e) +{-# INLINABLE reallocMByteArray #-} + + +isPinnedByteArray :: ByteArray p e -> Bool +isPinnedByteArray (ByteArray b) = isPinnedBytes b +{-# INLINE isPinnedByteArray #-} + +isPinnedMByteArray :: MByteArray p e s -> Bool +isPinnedMByteArray (MByteArray mb) = isPinnedMBytes mb +{-# INLINE isPinnedMByteArray #-} + +readMByteArray :: (MonadPrim s m, Prim e) => MByteArray p e s -> Int -> m e +readMByteArray (MByteArray mb) = readOffMBytes mb . coerce +{-# INLINE readMByteArray #-} + +writeMByteArray :: (MonadPrim s m, Prim e) => MByteArray p e s -> Int -> e -> m () +writeMByteArray (MByteArray mb) o = writeOffMBytes mb (coerce o) +{-# INLINE writeMByteArray #-} + + + +setMByteArray :: + (MonadPrim s m, Prim e) + => MByteArray p e s -- ^ Chunk of memory to fill + -> Int -- ^ Offset in number of elements + -> Size -- ^ Number of cells to fill + -> e -- ^ A value to fill the cells with + -> m () +setMByteArray (MByteArray mb) off sz = setMBytes mb (coerce off) (coerce sz) +{-# INLINE setMByteArray #-} + +copyByteArrayToMByteArray :: + (MonadPrim s m, Prim e) + => ByteArray p e + -> Int + -> MByteArray p e s + -> Int + -> Size + -> m () +copyByteArrayToMByteArray ba srcOff mba dstOff sz = + copyMem ba (coerce srcOff) mba (coerce dstOff) (countAsProxy ba (coerce sz)) +{-# INLINE copyByteArrayToMByteArray #-} + +moveMByteArrayToMByteArray :: + forall e p m s. (MonadPrim s m, Prim e) + => MByteArray p e s + -> Int + -> MByteArray p e s + -> Int + -> Size + -> m () +moveMByteArrayToMByteArray ba srcOff mba dstOff sz = + moveMem ba (coerce srcOff) mba (coerce dstOff) (coerce sz :: Count e) +{-# INLINE moveMByteArrayToMByteArray #-} + + + +-- toPtrByteArray :: ByteArray Pin e -> Ptr e +-- toPtrByteArray (ByteArray ba#) = Ptr (byteArrayContents# ba#) +-- {-# INLINE toPtrByteArray #-} + +-- toPtrMByteArray :: MByteArray Pin e s -> Ptr e +-- toPtrMByteArray (MByteArray mba#) = Ptr (mutableByteArrayContents# mba#) +-- {-# INLINE toPtrMByteArray #-} + +-- -- | Pointer access to immutable `ByteArray` should be for read only purposes, but it is +-- -- not enforced. Any mutation will break referential transparency +-- withPtrByteArray :: MonadPrim s m => ByteArray Pin e -> (Ptr e -> m b) -> m b +-- withPtrByteArray b f = do +-- res <- f (toPtrByteArray b) +-- res <$ touch b +-- {-# INLINE withPtrByteArray #-} + +-- -- | Same as `withPtrByteArray`, but is suitable for actions that don't terminate +-- withNoHaltPtrByteArray :: MonadUnliftPrim s m => ByteArray Pin e -> (Ptr e -> m b) -> m b +-- withNoHaltPtrByteArray b f = withAliveUnliftPrim b $ f (toPtrByteArray b) +-- {-# INLINE withNoHaltPtrByteArray #-} + +-- withPtrMByteArray :: MonadPrim s m => MByteArray Pin e s -> (Ptr e -> m b) -> m b +-- withPtrMByteArray mb f = do +-- res <- f (toPtrMByteArray mb) +-- res <$ touch mb +-- {-# INLINE withPtrMByteArray #-} + +-- withNoHaltPtrMByteArray :: MonadUnliftPrim s m => MByteArray Pin e s -> (Ptr e -> m b) -> m b +-- withNoHaltPtrMByteArray mb f = withAliveUnliftPrim mb $ f (toPtrMByteArray mb) +-- {-# INLINE withNoHaltPtrMByteArray #-} + + +-- -- -- | Check if two byte arrays refer to pinned memory and compare their pointers. +-- -- isSameByteArray :: ByteArray p1 e -> ByteArray p2 e -> Bool +-- -- isSameByteArray (ByteArray b1#) (ByteArray b2#) = isTrue# (isSameByteArray# b1# b2#) +-- -- {-# INLINE[0] isSameByteArray #-} +-- -- {-# RULES +-- -- "isSamePinnedByteArray" isSameByteArray = isSamePinnedByteArray +-- -- #-} + +-- -- -- | Perform pointer equality on pinned `ByteArray`. +-- -- isSamePinnedByteArray :: ByteArray Pin e -> ByteArray Pin e -> Bool +-- -- isSamePinnedByteArray pb e1 pb2 = toPtrByteArray pb e1 == toPtrByteArray pb e2 +-- -- {-# INLINE isSamePinnedByteArray #-} + + + +-- -- byteStringConvertError :: String -> a +-- -- byteStringConvertError msg = error $ "Cannot convert 'ByteString'. " ++ msg +-- -- {-# NOINLINE byteStringConvertError #-} + diff --git a/src/Data/Prim/Memory/ByteString.hs b/src/Data/Prim/Memory/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/ByteString.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.Prim.Memory.ByteString +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- 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 #-} diff --git a/src/Data/Prim/Memory/Bytes.hs b/src/Data/Prim/Memory/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Bytes.hs @@ -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 +-- 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 #-} + diff --git a/src/Data/Prim/Memory/Bytes/Internal.hs b/src/Data/Prim/Memory/Bytes/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Bytes/Internal.hs @@ -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 +-- 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 #-} + diff --git a/src/Data/Prim/Memory/ForeignPtr.hs b/src/Data/Prim/Memory/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/ForeignPtr.hs @@ -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 +-- 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 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 #-} diff --git a/src/Data/Prim/Memory/Internal.hs b/src/Data/Prim/Memory/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Internal.hs @@ -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 +-- 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) diff --git a/src/Data/Prim/Memory/Ptr.hs b/src/Data/Prim/Memory/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prim/Memory/Ptr.hs @@ -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 +-- 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 #-}