{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Crypto.Libsodium.Memory.Internal (
MLockedForeignPtr (..),
withMLockedForeignPtr,
finalizeMLockedForeignPtr,
traceMLockedForeignPtr,
mlockedMalloc,
MLockedAllocator (..),
mlockedAlloca,
mlockedAllocaSized,
mlockedAllocForeignPtr,
mlockedAllocForeignPtrBytes,
mlockedAllocaWith,
mlockedAllocaSizedWith,
mlockedAllocForeignPtrWith,
mlockedAllocForeignPtrBytesWith,
ForeignPtr (..),
mallocForeignPtrBytes,
withForeignPtr,
zeroMem,
copyMem,
allocaBytes,
unpackByteStringCStringLen,
packByteStringCStringLen,
unsafeIOToMonadST,
) where
import Control.DeepSeq (NFData (..), rwhnf)
import Control.Exception (Exception, mask_)
import Control.Monad (void, when)
import Control.Monad.Class.MonadST (MonadST, stToIO)
import Control.Monad.Class.MonadThrow (MonadThrow (bracket))
import Control.Monad.Primitive (touch)
import Control.Monad.ST (RealWorld, ST)
import Control.Monad.ST.Unsafe (unsafeIOToST)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Coerce (coerce)
import Data.Kind
import Data.Typeable
import Debug.Trace (traceShowM)
import Foreign.C.Error (errnoToIOError, getErrno)
import Foreign.C.String (CStringLen)
import Foreign.C.Types (CSize (..))
import qualified Foreign.Concurrent as Foreign
import qualified Foreign.ForeignPtr as Foreign hiding (newForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import qualified Foreign.ForeignPtr.Unsafe as Foreign
import Foreign.Marshal.Utils (fillBytes)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (Storable (peek), alignment, sizeOf)
import GHC.IO.Exception (ioException)
import GHC.TypeLits (KnownNat, natVal)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import System.IO.Unsafe (unsafePerformIO)
import System.Memory.Pool (Pool, grabNextBlock, initPool)
import Cardano.Crypto.Libsodium.C
import Cardano.Foreign (SizedPtr (..), c_memcpy, c_memset)
newtype MLockedForeignPtr a = SFP {forall a. MLockedForeignPtr a -> ForeignPtr a
_unwrapMLockedForeignPtr :: Foreign.ForeignPtr a}
deriving (Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
Proxy (MLockedForeignPtr a) -> String
(Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo))
-> (Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo))
-> (Proxy (MLockedForeignPtr a) -> String)
-> NoThunks (MLockedForeignPtr a)
forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
forall a. Proxy (MLockedForeignPtr a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
noThunks :: Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall a. Proxy (MLockedForeignPtr a) -> String
showTypeOf :: Proxy (MLockedForeignPtr a) -> String
NoThunks) via OnlyCheckWhnfNamed "MLockedForeignPtr" (MLockedForeignPtr a)
instance NFData (MLockedForeignPtr a) where
rnf :: MLockedForeignPtr a -> ()
rnf = ForeignPtr a -> ()
forall a. a -> ()
rwhnf (ForeignPtr a -> ())
-> (MLockedForeignPtr a -> ForeignPtr a)
-> MLockedForeignPtr a
-> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLockedForeignPtr a -> ForeignPtr a
forall a. MLockedForeignPtr a -> ForeignPtr a
_unwrapMLockedForeignPtr
withMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr :: forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr (SFP ForeignPtr a
fptr) Ptr a -> m b
f = do
b
r <- Ptr a -> m b
f (ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr a
fptr)
b
r b -> m () -> m b
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
Foreign.touchForeignPtr ForeignPtr a
fptr)
finalizeMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr :: forall (m :: * -> *) a. MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr (SFP ForeignPtr a
fptr) =
IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
Foreign.finalizeForeignPtr ForeignPtr a
fptr
{-# WARNING traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-}
traceMLockedForeignPtr :: (Storable a, Show a, MonadST m) => MLockedForeignPtr a -> m ()
traceMLockedForeignPtr :: forall a (m :: * -> *).
(Storable a, Show a, MonadST m) =>
MLockedForeignPtr a -> m ()
traceMLockedForeignPtr MLockedForeignPtr a
fptr = MLockedForeignPtr a -> (Ptr a -> m ()) -> m ()
forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr MLockedForeignPtr a
fptr ((Ptr a -> m ()) -> m ()) -> (Ptr a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
a
a <- IO a -> m a
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr)
a -> m ()
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM a
a
unsafeIOToMonadST :: MonadST m => IO a -> m a
unsafeIOToMonadST :: forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST = ST (PrimState m) a -> m a
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) a -> m a)
-> (IO a -> ST (PrimState m) a) -> IO a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ST (PrimState m) a
forall a s. IO a -> ST s a
unsafeIOToST
makeMLockedPool :: forall n s. KnownNat n => ST s (Pool n s)
makeMLockedPool :: forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool = do
Int
-> (forall a. Int -> ST s (ForeignPtr a))
-> (Ptr (Block n) -> IO ())
-> ST s (Pool n s)
forall (n :: Nat) s.
KnownNat n =>
Int
-> (forall a. Int -> ST s (ForeignPtr a))
-> (Ptr (Block n) -> IO ())
-> ST s (Pool n s)
initPool
(Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> (Integer -> Int) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
4096 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
64)
( \Int
size -> IO (ForeignPtr a) -> ST s (ForeignPtr a)
forall a s. IO a -> ST s a
unsafeIOToST (IO (ForeignPtr a) -> ST s (ForeignPtr a))
-> IO (ForeignPtr a) -> ST s (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ IO (ForeignPtr a) -> IO (ForeignPtr a)
forall a. IO a -> IO a
mask_ (IO (ForeignPtr a) -> IO (ForeignPtr a))
-> IO (ForeignPtr a) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ do
Ptr a
ptr <- CSize -> IO (Ptr a)
forall a. CSize -> IO (Ptr a)
sodiumMalloc (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
Ptr a -> IO () -> IO (ForeignPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Foreign.newForeignPtr Ptr a
ptr (Ptr a -> CSize -> IO ()
forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))
)
( \Ptr (Block n)
ptr -> do
Proxy n -> Ptr (Block n) -> IO ()
forall (n :: Nat) a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n) Ptr (Block n)
ptr
)
eraseMem :: forall n a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem :: forall (n :: Nat) a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem Proxy n
proxy Ptr a
ptr = Ptr a -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr a
ptr Word8
0xff (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal Proxy n
proxy)
mlockedPool32 :: Pool 32 RealWorld
mlockedPool32 :: Pool 32 RealWorld
mlockedPool32 = IO (Pool 32 RealWorld) -> Pool 32 RealWorld
forall a. IO a -> a
unsafePerformIO (IO (Pool 32 RealWorld) -> Pool 32 RealWorld)
-> IO (Pool 32 RealWorld) -> Pool 32 RealWorld
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (Pool 32 RealWorld) -> IO (Pool 32 RealWorld)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO ST RealWorld (Pool 32 RealWorld)
ST (PrimState IO) (Pool 32 RealWorld)
forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool32 #-}
mlockedPool64 :: Pool 64 RealWorld
mlockedPool64 :: Pool 64 RealWorld
mlockedPool64 = IO (Pool 64 RealWorld) -> Pool 64 RealWorld
forall a. IO a -> a
unsafePerformIO (IO (Pool 64 RealWorld) -> Pool 64 RealWorld)
-> IO (Pool 64 RealWorld) -> Pool 64 RealWorld
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (Pool 64 RealWorld) -> IO (Pool 64 RealWorld)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO ST RealWorld (Pool 64 RealWorld)
ST (PrimState IO) (Pool 64 RealWorld)
forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool64 #-}
mlockedPool128 :: Pool 128 RealWorld
mlockedPool128 :: Pool 128 RealWorld
mlockedPool128 = IO (Pool 128 RealWorld) -> Pool 128 RealWorld
forall a. IO a -> a
unsafePerformIO (IO (Pool 128 RealWorld) -> Pool 128 RealWorld)
-> IO (Pool 128 RealWorld) -> Pool 128 RealWorld
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (Pool 128 RealWorld) -> IO (Pool 128 RealWorld)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO ST RealWorld (Pool 128 RealWorld)
ST (PrimState IO) (Pool 128 RealWorld)
forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool128 #-}
mlockedPool256 :: Pool 256 RealWorld
mlockedPool256 :: Pool 256 RealWorld
mlockedPool256 = IO (Pool 256 RealWorld) -> Pool 256 RealWorld
forall a. IO a -> a
unsafePerformIO (IO (Pool 256 RealWorld) -> Pool 256 RealWorld)
-> IO (Pool 256 RealWorld) -> Pool 256 RealWorld
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (Pool 256 RealWorld) -> IO (Pool 256 RealWorld)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO ST RealWorld (Pool 256 RealWorld)
ST (PrimState IO) (Pool 256 RealWorld)
forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool256 #-}
mlockedPool512 :: Pool 512 RealWorld
mlockedPool512 :: Pool 512 RealWorld
mlockedPool512 = IO (Pool 512 RealWorld) -> Pool 512 RealWorld
forall a. IO a -> a
unsafePerformIO (IO (Pool 512 RealWorld) -> Pool 512 RealWorld)
-> IO (Pool 512 RealWorld) -> Pool 512 RealWorld
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (Pool 512 RealWorld) -> IO (Pool 512 RealWorld)
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO ST RealWorld (Pool 512 RealWorld)
ST (PrimState IO) (Pool 512 RealWorld)
forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool512 #-}
data AllocatorException
= AllocatorNoTracer
| AllocatorNoGenerator
deriving (Int -> AllocatorException -> ShowS
[AllocatorException] -> ShowS
AllocatorException -> String
(Int -> AllocatorException -> ShowS)
-> (AllocatorException -> String)
-> ([AllocatorException] -> ShowS)
-> Show AllocatorException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AllocatorException -> ShowS
showsPrec :: Int -> AllocatorException -> ShowS
$cshow :: AllocatorException -> String
show :: AllocatorException -> String
$cshowList :: [AllocatorException] -> ShowS
showList :: [AllocatorException] -> ShowS
Show)
instance Exception AllocatorException
mlockedMalloc :: MonadST m => MLockedAllocator m
mlockedMalloc :: forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc =
MLockedAllocator {mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate = IO (MLockedForeignPtr a) -> m (MLockedForeignPtr a)
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO (MLockedForeignPtr a) -> m (MLockedForeignPtr a))
-> (CSize -> IO (MLockedForeignPtr a))
-> CSize
-> m (MLockedForeignPtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSize -> IO (MLockedForeignPtr a)
forall a. CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO}
mlockedMallocIO :: CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO :: forall a. CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO CSize
size =
ForeignPtr a -> MLockedForeignPtr a
forall a. ForeignPtr a -> MLockedForeignPtr a
SFP (ForeignPtr a -> MLockedForeignPtr a)
-> IO (ForeignPtr a) -> IO (MLockedForeignPtr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
if
| CSize
size CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
<= CSize
32 -> do
(ForeignPtr (Block 32) -> ForeignPtr a)
-> IO (ForeignPtr (Block 32)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (Block 32) -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce (IO (ForeignPtr (Block 32)) -> IO (ForeignPtr a))
-> IO (ForeignPtr (Block 32)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (ForeignPtr (Block 32))
-> IO (ForeignPtr (Block 32))
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState IO) (ForeignPtr (Block 32))
-> IO (ForeignPtr (Block 32)))
-> ST (PrimState IO) (ForeignPtr (Block 32))
-> IO (ForeignPtr (Block 32))
forall a b. (a -> b) -> a -> b
$ Pool 32 RealWorld -> ST RealWorld (ForeignPtr (Block 32))
forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 32 RealWorld
mlockedPool32
| CSize
size CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
<= CSize
64 -> do
(ForeignPtr (Block 64) -> ForeignPtr a)
-> IO (ForeignPtr (Block 64)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (Block 64) -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce (IO (ForeignPtr (Block 64)) -> IO (ForeignPtr a))
-> IO (ForeignPtr (Block 64)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (ForeignPtr (Block 64))
-> IO (ForeignPtr (Block 64))
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState IO) (ForeignPtr (Block 64))
-> IO (ForeignPtr (Block 64)))
-> ST (PrimState IO) (ForeignPtr (Block 64))
-> IO (ForeignPtr (Block 64))
forall a b. (a -> b) -> a -> b
$ Pool 64 RealWorld -> ST RealWorld (ForeignPtr (Block 64))
forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 64 RealWorld
mlockedPool64
| CSize
size CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
<= CSize
128 -> do
(ForeignPtr (Block 128) -> ForeignPtr a)
-> IO (ForeignPtr (Block 128)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (Block 128) -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce (IO (ForeignPtr (Block 128)) -> IO (ForeignPtr a))
-> IO (ForeignPtr (Block 128)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (ForeignPtr (Block 128))
-> IO (ForeignPtr (Block 128))
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState IO) (ForeignPtr (Block 128))
-> IO (ForeignPtr (Block 128)))
-> ST (PrimState IO) (ForeignPtr (Block 128))
-> IO (ForeignPtr (Block 128))
forall a b. (a -> b) -> a -> b
$ Pool 128 RealWorld -> ST RealWorld (ForeignPtr (Block 128))
forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 128 RealWorld
mlockedPool128
| CSize
size CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
<= CSize
256 -> do
(ForeignPtr (Block 256) -> ForeignPtr a)
-> IO (ForeignPtr (Block 256)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (Block 256) -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce (IO (ForeignPtr (Block 256)) -> IO (ForeignPtr a))
-> IO (ForeignPtr (Block 256)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (ForeignPtr (Block 256))
-> IO (ForeignPtr (Block 256))
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState IO) (ForeignPtr (Block 256))
-> IO (ForeignPtr (Block 256)))
-> ST (PrimState IO) (ForeignPtr (Block 256))
-> IO (ForeignPtr (Block 256))
forall a b. (a -> b) -> a -> b
$ Pool 256 RealWorld -> ST RealWorld (ForeignPtr (Block 256))
forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 256 RealWorld
mlockedPool256
| CSize
size CSize -> CSize -> Bool
forall a. Ord a => a -> a -> Bool
<= CSize
512 -> do
(ForeignPtr (Block 512) -> ForeignPtr a)
-> IO (ForeignPtr (Block 512)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr (Block 512) -> ForeignPtr a
forall a b. Coercible a b => a -> b
coerce (IO (ForeignPtr (Block 512)) -> IO (ForeignPtr a))
-> IO (ForeignPtr (Block 512)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ ST (PrimState IO) (ForeignPtr (Block 512))
-> IO (ForeignPtr (Block 512))
forall a. ST (PrimState IO) a -> IO a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState IO) (ForeignPtr (Block 512))
-> IO (ForeignPtr (Block 512)))
-> ST (PrimState IO) (ForeignPtr (Block 512))
-> IO (ForeignPtr (Block 512))
forall a b. (a -> b) -> a -> b
$ Pool 512 RealWorld -> ST RealWorld (ForeignPtr (Block 512))
forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 512 RealWorld
mlockedPool512
| Bool
otherwise -> do
IO (ForeignPtr a) -> IO (ForeignPtr a)
forall a. IO a -> IO a
mask_ (IO (ForeignPtr a) -> IO (ForeignPtr a))
-> IO (ForeignPtr a) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ do
Ptr a
ptr <- CSize -> IO (Ptr a)
forall a. CSize -> IO (Ptr a)
sodiumMalloc CSize
size
Ptr a -> IO () -> IO (ForeignPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Foreign.newForeignPtr Ptr a
ptr (IO () -> IO (ForeignPtr a)) -> IO () -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ do
Ptr a -> CSize -> IO ()
forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr CSize
size
sodiumMalloc :: CSize -> IO (Ptr a)
sodiumMalloc :: forall a. CSize -> IO (Ptr a)
sodiumMalloc CSize
size = do
Ptr a
ptr <- CSize -> IO (Ptr a)
forall a. CSize -> IO (Ptr a)
c_sodium_malloc CSize
size
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr a
ptr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Errno
errno <- IO Errno
getErrno
IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_malloc" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
CInt
res <- Ptr a -> CSize -> IO CInt
forall a. Ptr a -> CSize -> IO CInt
c_sodium_mlock Ptr a
ptr CSize
size
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Errno
errno <- IO Errno
getErrno
IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_mlock" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
Ptr a -> IO (Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr
sodiumFree :: Ptr a -> CSize -> IO ()
sodiumFree :: forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr CSize
size = do
CInt
res <- Ptr a -> CSize -> IO CInt
forall a. Ptr a -> CSize -> IO CInt
c_sodium_munlock Ptr a
ptr CSize
size
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Errno
errno <- IO Errno
getErrno
IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_munlock" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
Ptr a -> IO ()
forall a. Ptr a -> IO ()
c_sodium_free Ptr a
ptr
zeroMem :: MonadST m => Ptr a -> CSize -> m ()
zeroMem :: forall (m :: * -> *) a. MonadST m => Ptr a -> CSize -> m ()
zeroMem Ptr a
ptr CSize
size = IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO () -> m ()) -> (IO (Ptr ()) -> IO ()) -> IO (Ptr ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Ptr ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr ()) -> m ()) -> IO (Ptr ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr Any -> Int -> CSize -> IO (Ptr ())
forall a. Ptr a -> Int -> CSize -> IO (Ptr ())
c_memset (Ptr a -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
0 CSize
size
copyMem :: MonadST m => Ptr a -> Ptr a -> CSize -> m ()
copyMem :: forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem Ptr a
dst Ptr a
src CSize
size = IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO () -> m ()) -> (IO (Ptr ()) -> IO ()) -> IO (Ptr ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Ptr ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr ()) -> m ()) -> IO (Ptr ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr Any -> Ptr Any -> CSize -> IO (Ptr ())
forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr ())
c_memcpy (Ptr a -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr a
dst) (Ptr a -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr a
src) CSize
size
newtype ForeignPtr (m :: Type -> Type) a = ForeignPtr {forall (m :: * -> *) a. ForeignPtr m a -> ForeignPtr a
unsafeRawForeignPtr :: Foreign.ForeignPtr a}
mallocForeignPtrBytes :: MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes :: forall (m :: * -> *) a. MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes Int
size =
ForeignPtr a -> ForeignPtr m a
forall (m :: * -> *) a. ForeignPtr a -> ForeignPtr m a
ForeignPtr (ForeignPtr a -> ForeignPtr m a)
-> m (ForeignPtr a) -> m (ForeignPtr m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (ForeignPtr a) -> m (ForeignPtr a)
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (Int -> IO (ForeignPtr a)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes Int
size)
withForeignPtr :: MonadST m => ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr :: forall (m :: * -> *) a b.
MonadST m =>
ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr (ForeignPtr ForeignPtr a
fptr) Ptr a -> m b
f = do
b
result <- Ptr a -> m b
f (Ptr a -> m b) -> Ptr a -> m b
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
Foreign.unsafeForeignPtrToPtr ForeignPtr a
fptr
ST (PrimState m) () -> m ()
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> ST (PrimState m) ()
forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch ForeignPtr a
fptr
b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
allocaBytes :: (MonadThrow m, MonadST m) => Int -> (Ptr a -> m b) -> m b
allocaBytes :: forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
size Ptr a -> m b
action = do
ForeignPtr m a
fptr <- Int -> m (ForeignPtr m a)
forall (m :: * -> *) a. MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes Int
size
ForeignPtr m a -> (Ptr a -> m b) -> m b
forall (m :: * -> *) a b.
MonadST m =>
ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr ForeignPtr m a
fptr Ptr a -> m b
action
unpackByteStringCStringLen :: (MonadThrow m, MonadST m) => ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen :: forall (m :: * -> *) a.
(MonadThrow m, MonadST m) =>
ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen ByteString
bs CStringLen -> m a
f = do
let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
Int -> (Ptr CChar -> m a) -> m a
forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
len ((Ptr CChar -> m a) -> m a) -> (Ptr CChar -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buf -> do
IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO ()) -> IO ()
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
ptr -> do
Ptr CChar -> Ptr CChar -> CSize -> IO ()
forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem Ptr CChar
buf Ptr CChar
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
CStringLen -> m a
f (Ptr CChar
buf, Int
len)
packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString
packByteStringCStringLen :: forall (m :: * -> *). MonadST m => CStringLen -> m ByteString
packByteStringCStringLen =
IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO ByteString -> m ByteString)
-> (CStringLen -> IO ByteString) -> CStringLen -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStringLen -> IO ByteString
BS.packCStringLen
newtype MLockedAllocator m
= MLockedAllocator
{ forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a)
}
mlockedAllocaSized ::
forall m n b. (MonadST m, MonadThrow m, KnownNat n) => (SizedPtr n -> m b) -> m b
mlockedAllocaSized :: forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
(SizedPtr n -> m b) -> m b
mlockedAllocaSized = MLockedAllocator m -> (SizedPtr n -> m b) -> m b
forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
MLockedAllocator m -> (SizedPtr n -> m b) -> m b
mlockedAllocaSizedWith MLockedAllocator m
forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc
mlockedAllocaSizedWith ::
forall m n b.
(MonadST m, MonadThrow m, KnownNat n) =>
MLockedAllocator m ->
(SizedPtr n -> m b) ->
m b
mlockedAllocaSizedWith :: forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
MLockedAllocator m -> (SizedPtr n -> m b) -> m b
mlockedAllocaSizedWith MLockedAllocator m
allocator SizedPtr n -> m b
k = MLockedAllocator m -> CSize -> (Ptr Void -> m b) -> m b
forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith MLockedAllocator m
allocator CSize
size (SizedPtr n -> m b
k (SizedPtr n -> m b) -> (Ptr Void -> SizedPtr n) -> Ptr Void -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Void -> SizedPtr n
forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr)
where
size :: CSize
size :: CSize
size = Integer -> CSize
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n))
mlockedAllocForeignPtrBytes :: MonadST m => CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytes :: forall (m :: * -> *) a.
MonadST m =>
CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytes = MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith MLockedAllocator m
forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc
mlockedAllocForeignPtrBytesWith :: MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith :: forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith MLockedAllocator m
_ CSize
_ CSize
0 =
String -> m (MLockedForeignPtr a)
forall a. HasCallStack => String -> a
error String
"Zero alignment"
mlockedAllocForeignPtrBytesWith MLockedAllocator m
allocator CSize
size CSize
align = do
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator m
allocator CSize
size'
where
size' :: CSize
size' :: CSize
size'
| CSize
m CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
== CSize
0 = CSize
size
| Bool
otherwise = (CSize
q CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
+ CSize
1) CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
* CSize
align
where
(CSize
q, CSize
m) = CSize
size CSize -> CSize -> (CSize, CSize)
forall a. Integral a => a -> a -> (a, a)
`quotRem` CSize
align
mlockedAllocForeignPtr :: forall a m. (MonadST m, Storable a) => m (MLockedForeignPtr a)
mlockedAllocForeignPtr :: forall a (m :: * -> *).
(MonadST m, Storable a) =>
m (MLockedForeignPtr a)
mlockedAllocForeignPtr = MLockedAllocator m -> m (MLockedForeignPtr a)
forall a (m :: * -> *).
Storable a =>
MLockedAllocator m -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith MLockedAllocator m
forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc
mlockedAllocForeignPtrWith ::
forall a m.
Storable a =>
MLockedAllocator m ->
m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith :: forall a (m :: * -> *).
Storable a =>
MLockedAllocator m -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith MLockedAllocator m
allocator =
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith MLockedAllocator m
allocator CSize
size CSize
align
where
dummy :: a
dummy :: a
dummy = a
forall a. HasCallStack => a
undefined
size :: CSize
size :: CSize
size = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Storable a => a -> Int
sizeOf a
dummy
align :: CSize
align :: CSize
align = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Storable a => a -> Int
alignment a
dummy
mlockedAlloca :: forall a b m. (MonadST m, MonadThrow m) => CSize -> (Ptr a -> m b) -> m b
mlockedAlloca :: forall a b (m :: * -> *).
(MonadST m, MonadThrow m) =>
CSize -> (Ptr a -> m b) -> m b
mlockedAlloca = MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith MLockedAllocator m
forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc
mlockedAllocaWith ::
forall a b m.
(MonadThrow m, MonadST m) =>
MLockedAllocator m ->
CSize ->
(Ptr a -> m b) ->
m b
mlockedAllocaWith :: forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith MLockedAllocator m
allocator CSize
size =
m (MLockedForeignPtr a)
-> (MLockedForeignPtr a -> m ())
-> (MLockedForeignPtr a -> m b)
-> m b
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (MLockedForeignPtr a)
alloc MLockedForeignPtr a -> m ()
forall (m :: * -> *) a. MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr ((MLockedForeignPtr a -> m b) -> m b)
-> ((Ptr a -> m b) -> MLockedForeignPtr a -> m b)
-> (Ptr a -> m b)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MLockedForeignPtr a -> (Ptr a -> m b) -> m b)
-> (Ptr a -> m b) -> MLockedForeignPtr a -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip MLockedForeignPtr a -> (Ptr a -> m b) -> m b
forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr
where
alloc :: m (MLockedForeignPtr a)
alloc = MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator m
allocator CSize
size