{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

-- |
-- Module      : Streamly.Internal.Data.MutByteArray.Type
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.MutByteArray.Type
    (
    -- ** MutByteArray
      MutByteArray(..)
    , getMutByteArray#

    -- ** Helpers
    , touch

    -- ** Pinning
    , PinnedState(..)
    , isPinned
    , pin
    , unpin

    -- ** Allocation
    , empty
    , newAs
    , new
    , new'
    , reallocSliceAs

    -- ** Access
    , length
    , unsafeAsPtr

    -- ** Modify
    , unsafePutSlice
    , unsafePutPtrN

    -- ** Copy
    , unsafeCloneSliceAs
    , unsafeCloneSlice
    , unsafePinnedCloneSlice -- XXX unsafeCloneSlice'

    -- ** Compare
    , unsafeByteCmp

    -- ** Capacity Management
    , blockSize
    , largeObjectThreshold

    -- ** Deprecated
    , MutableByteArray
    , getMutableByteArray#
    , newBytesAs
    , sizeOfMutableByteArray
    , putSliceUnsafe
    , cloneSliceUnsafeAs
    , cloneSliceUnsafe
    , pinnedCloneSliceUnsafe
    , pinnedNewAlignedBytes
    , asPtrUnsafe
    , unsafePinnedAsPtr
    , nil
    , pinnedNew
    ) where

#include "deprecation.h"

import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (when)
import Data.Word (Word8)
#ifdef DEBUG
import Debug.Trace (trace)
#endif
import Foreign.C.Types (CSize(..))
import GHC.Base (IO(..))
import System.IO.Unsafe (unsafePerformIO)

import GHC.Exts
import Prelude hiding (length)

--------------------------------------------------------------------------------
-- The ArrayContents type
--------------------------------------------------------------------------------

data PinnedState
    = Pinned
    | Unpinned deriving (Int -> PinnedState -> ShowS
[PinnedState] -> ShowS
PinnedState -> String
(Int -> PinnedState -> ShowS)
-> (PinnedState -> String)
-> ([PinnedState] -> ShowS)
-> Show PinnedState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PinnedState -> ShowS
showsPrec :: Int -> PinnedState -> ShowS
$cshow :: PinnedState -> String
show :: PinnedState -> String
$cshowList :: [PinnedState] -> ShowS
showList :: [PinnedState] -> ShowS
Show, PinnedState -> PinnedState -> Bool
(PinnedState -> PinnedState -> Bool)
-> (PinnedState -> PinnedState -> Bool) -> Eq PinnedState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PinnedState -> PinnedState -> Bool
== :: PinnedState -> PinnedState -> Bool
$c/= :: PinnedState -> PinnedState -> Bool
/= :: PinnedState -> PinnedState -> Bool
Eq)

-- XXX can use UnliftedNewtypes

-- | A lifted mutable byte array type wrapping @MutableByteArray# RealWorld@.
-- This is a low level array used to back high level unboxed arrays and
-- serialized data.
data MutByteArray = MutByteArray (MutableByteArray# RealWorld)

{-# DEPRECATED MutableByteArray "Please use MutByteArray instead" #-}
type MutableByteArray = MutByteArray

{-# INLINE getMutByteArray# #-}
getMutableByteArray#, getMutByteArray# :: MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# :: MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# (MutByteArray MutableByteArray# RealWorld
mbarr) = MutableByteArray# RealWorld
mbarr

-- | Return the size of the array in bytes.
{-# INLINE length #-}
sizeOfMutableByteArray, length :: MutByteArray -> IO Int
length :: MutByteArray -> IO Int
length (MutByteArray MutableByteArray# RealWorld
arr) =
    (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
        case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, Int# #)
forall d. MutableByteArray# d -> State# d -> (# State# d, Int# #)
getSizeofMutableByteArray# MutableByteArray# RealWorld
arr State# RealWorld
s of
            (# State# RealWorld
s1, Int#
i #) -> (# State# RealWorld
s1, Int# -> Int
I# Int#
i #)

{-# INLINE touch #-}
touch :: MutByteArray -> IO ()
touch :: MutByteArray -> IO ()
touch (MutByteArray MutableByteArray# RealWorld
contents) =
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutableByteArray# RealWorld -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# MutableByteArray# RealWorld
contents State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

-- XXX Some functions in this module are "IO" and others are "m", we need to
-- make it consistent.

-- | NOTE: this is deprecated because it can lead to accidental problems if the
-- user tries to use it to mutate the array because it does not return the new
-- array after pinning.
{-# DEPRECATED unsafePinnedAsPtr "Pin the array and then use unsafeAsPtr." #-}
{-# INLINE unsafePinnedAsPtr #-}
unsafePinnedAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b
unsafePinnedAsPtr :: forall (m :: * -> *) a b.
MonadIO m =>
MutByteArray -> (Ptr a -> m b) -> m b
unsafePinnedAsPtr MutByteArray
arr0 Ptr a -> m b
f = do
    MutByteArray
arr <- IO MutByteArray -> m MutByteArray
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MutByteArray -> m MutByteArray)
-> IO MutByteArray -> m MutByteArray
forall a b. (a -> b) -> a -> b
$ MutByteArray -> IO MutByteArray
pin MutByteArray
arr0
    let !ptr :: Ptr a
ptr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents#
                     (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# (MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# MutByteArray
arr)))
    b
r <- Ptr a -> m b
f Ptr a
forall {a}. Ptr a
ptr
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MutByteArray -> IO ()
touch MutByteArray
arr
    b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r

{-# DEPRECATED asPtrUnsafe "Pin the array and then use unsafeAsPtr." #-}
{-# INLINE asPtrUnsafe #-}
asPtrUnsafe :: MonadIO m => MutByteArray -> (Ptr a -> m b) -> m b
asPtrUnsafe :: forall (m :: * -> *) a b.
MonadIO m =>
MutByteArray -> (Ptr a -> m b) -> m b
asPtrUnsafe = MutByteArray -> (Ptr a -> m b) -> m b
forall (m :: * -> *) a b.
MonadIO m =>
MutByteArray -> (Ptr a -> m b) -> m b
unsafePinnedAsPtr

-- | Use a @MutByteArray@ as @Ptr a@. This is useful when we want to pass
-- an array as a pointer to some operating system call or to a "safe" FFI call.
--
-- /Unsafe/ WARNING:
--
-- 1. Will lead to memory corruption if the array is not pinned. Use
-- only if the array is known to be pinned already or pin it explicitly.
--
-- 2. Ensure that the pointer is accessed within the legal bounds of the array.
-- The size of the MutByteArray must be taken into account.
--
-- /Pre-release/
--
{-# INLINE unsafeAsPtr #-}
unsafeAsPtr :: MonadIO m => MutByteArray -> (Ptr a -> IO b) -> m b
unsafeAsPtr :: forall (m :: * -> *) a b.
MonadIO m =>
MutByteArray -> (Ptr a -> IO b) -> m b
unsafeAsPtr MutByteArray
arr Ptr a -> IO b
f = IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (MutByteArray -> Bool
isPinned MutByteArray
arr))
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"unsafeAsPtr requires the array to be pinned"

    let !ptr :: Ptr a
ptr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents#
                     (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# (MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# MutByteArray
arr)))
    b
r <- Ptr a -> IO b
f Ptr a
forall {a}. Ptr a
ptr
    -- While f is using the bare pointer, the MutByteArray may be garbage
    -- collected by the GC, tell the GC that we are still using it.
    MutByteArray -> IO ()
touch MutByteArray
arr
    b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r

--------------------------------------------------------------------------------
-- Creation
--------------------------------------------------------------------------------

{-# NOINLINE empty #-}
empty :: MutByteArray
empty :: MutByteArray
empty = IO MutByteArray -> MutByteArray
forall a. IO a -> a
unsafePerformIO (IO MutByteArray -> MutByteArray)
-> IO MutByteArray -> MutByteArray
forall a b. (a -> b) -> a -> b
$ Int -> IO MutByteArray
new Int
0

{-# DEPRECATED nil "Please use empty instead" #-}
nil :: MutByteArray
nil :: MutByteArray
nil = MutByteArray
empty

-- XXX Should we use bitshifts in calculations or it gets optimized by the
-- compiler/processor itself?
--
-- | The page or block size used by the GHC allocator. Allocator allocates at
-- least a block and then allocates smaller allocations from within a block.
blockSize :: Int
blockSize :: Int
blockSize = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

-- | Allocations larger than 'largeObjectThreshold' are in multiples of block
-- size and are always pinned. The space beyond the end of a large object up to
-- the end of the block is unused.
largeObjectThreshold :: Int
largeObjectThreshold :: Int
largeObjectThreshold = (Int
blockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10

{-# INLINE pinnedNewRaw #-}
pinnedNewRaw :: Int -> IO MutByteArray
pinnedNewRaw :: Int -> IO MutByteArray
pinnedNewRaw (I# Int#
nbytes) = (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
nbytes State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutByteArray
c = MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutByteArray
c #)

{-# INLINE new' #-}
new', pinnedNew :: Int -> IO MutByteArray
new' :: Int -> IO MutByteArray
new' Int
nbytes | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
  String -> IO MutByteArray
forall a. String -> a
errorWithoutStackTrace String
"new': size must be >= 0"
new' Int
nbytes = Int -> IO MutByteArray
pinnedNewRaw Int
nbytes
RENAME_PRIME(pinnedNew,new)

-- XXX add "newRoundedUp" to round up the large size to the next page boundary
-- and return the allocated size.
-- Uses the pinned version of allocated if the size required is >
-- largeObjectThreshold
{-# INLINE new #-}
new :: Int -> IO MutByteArray
new :: Int -> IO MutByteArray
new Int
nbytes | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
largeObjectThreshold = Int -> IO MutByteArray
pinnedNewRaw Int
nbytes
new Int
nbytes | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
  String -> IO MutByteArray
forall a. String -> a
errorWithoutStackTrace String
"newByteArray: size must be >= 0"
new (I# Int#
nbytes) = (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
nbytes State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutByteArray
c = MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutByteArray
c #)

{-# DEPRECATED pinnedNewAlignedBytes "Please use pinnedNew instead" #-}
{-# INLINE pinnedNewAlignedBytes #-}
pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray
pinnedNewAlignedBytes :: Int -> Int -> IO MutByteArray
pinnedNewAlignedBytes Int
nbytes Int
_align | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
  String -> IO MutByteArray
forall a. String -> a
errorWithoutStackTrace String
"pinnedNewAlignedBytes: size must be >= 0"
pinnedNewAlignedBytes (I# Int#
nbytes) (I# Int#
align) = (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
nbytes Int#
align State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutByteArray
c = MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutByteArray
c #)

{-# INLINE newAs #-}
newBytesAs, newAs :: PinnedState -> Int -> IO MutByteArray
newAs :: PinnedState -> Int -> IO MutByteArray
newAs PinnedState
Unpinned = Int -> IO MutByteArray
new
newAs PinnedState
Pinned = Int -> IO MutByteArray
pinnedNew

-- | @reallocSliceAs pinType newLen array offset len@ reallocates a slice
-- from @array@ starting at @offset@ and having length @len@ to a new array of
-- length @newLen@ copying the old data to the new. Note that if the @newLen@
-- is smaller than @len@ it will truncate the old data.
{-# INLINE reallocSliceAs #-}
reallocSliceAs ::
    PinnedState -> Int -> MutByteArray -> Int -> Int -> IO MutByteArray
reallocSliceAs :: PinnedState -> Int -> MutByteArray -> Int -> Int -> IO MutByteArray
reallocSliceAs PinnedState
ps Int
newLen (MutByteArray MutableByteArray# RealWorld
src#) Int
srcStart Int
srcLen = do
    MutByteArray MutableByteArray# RealWorld
dst# <- PinnedState -> Int -> IO MutByteArray
newBytesAs PinnedState
ps Int
newLen

    -- Copy old data
    let !(I# Int#
srcStart#) = Int
srcStart
        !(I# Int#
newLen#) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
srcLen Int
newLen
    (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> (# MutableByteArray# RealWorld
-> Int#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray# MutableByteArray# RealWorld
src# Int#
srcStart#
                        MutableByteArray# RealWorld
dst# Int#
0# Int#
newLen# State# RealWorld
s#, MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
dst# #)

-------------------------------------------------------------------------------
-- Copying
-------------------------------------------------------------------------------

-- Note: Array copy is more efficient than streaming copy.
-- CopyMutableByteArray# translates to genMemcpy in GHC/CmmToAsm/X86/CodeGen.hs
-- glibc memcpy copies bytes/words/pages - unrolls the loops:
-- https://github.com/bminor/glibc/blob/4290aed05135ae4c0272006442d147f2155e70d7/string/memcpy.c
-- https://github.com/bminor/glibc/blob/4290aed05135ae4c0272006442d147f2155e70d7/string/wordcopy.c

-- | @unsafePutSlice src srcOffset dst dstOffset len@ copies @len@ bytes from
-- @src@ at @srcOffset@ to dst at @dstOffset@.
--
-- This is unsafe as it does not check the bounds of @src@ or @dst@.
--
{-# INLINE unsafePutSlice #-}
putSliceUnsafe, unsafePutSlice ::
       MonadIO m
    => MutByteArray
    -> Int
    -> MutByteArray
    -> Int
    -> Int
    -> m ()
unsafePutSlice :: forall (m :: * -> *).
MonadIO m =>
MutByteArray -> Int -> MutByteArray -> Int -> Int -> m ()
unsafePutSlice MutByteArray
src Int
srcStartBytes MutByteArray
dst Int
dstStartBytes Int
lenBytes = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef DEBUG
    srcLen <- length src
    dstLen <- length dst
    when (srcLen - srcStartBytes < lenBytes)
        $ error $ "unsafePutSlice: src overflow: start" ++ show srcStartBytes
            ++ " end " ++ show srcLen ++ " len " ++ show lenBytes
    when (dstLen - dstStartBytes < lenBytes)
        $ error $ "unsafePutSlice: dst overflow: start" ++ show dstStartBytes
            ++ " end " ++ show dstLen ++ " len " ++ show lenBytes
#endif
    let !(I# Int#
srcStartBytes#) = Int
srcStartBytes
        !(I# Int#
dstStartBytes#) = Int
dstStartBytes
        !(I# Int#
lenBytes#) = Int
lenBytes
    let arrS# :: MutableByteArray# RealWorld
arrS# = MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# MutByteArray
src
        arrD# :: MutableByteArray# RealWorld
arrD# = MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# MutByteArray
dst
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> (# MutableByteArray# RealWorld
-> Int#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray#
                    MutableByteArray# RealWorld
arrS# Int#
srcStartBytes# MutableByteArray# RealWorld
arrD# Int#
dstStartBytes# Int#
lenBytes# State# RealWorld
s#
                , () #)

foreign import ccall unsafe "string.h memcpy" c_memcpy_pinned
    :: Addr# -> Addr# -> CSize -> IO (Ptr Word8)

-- | @unsafePutPtrN srcPtr dst dstOffset len@ copies @len@ bytes from @srcPtr@
-- to dst at @dstOffset@.
--
-- /Unsafe/:
--
-- The caller has to ensure that:
--
-- * the MutByteArray @dst@ is valid up to @dstOffset + len@.
-- * the @srcPtr@ is alive and pinned during the call.
-- * the @srcPtr@ is valid up to length @len@.
--
{-# INLINE unsafePutPtrN #-}
unsafePutPtrN ::
       MonadIO m
    => Ptr Word8
    -> MutByteArray
    -> Int
    -> Int
    -> m ()
unsafePutPtrN :: forall (m :: * -> *).
MonadIO m =>
Ptr Word8 -> MutByteArray -> Int -> Int -> m ()
unsafePutPtrN (Ptr Addr#
srcAddr) MutByteArray
dst Int
dstOffset Int
len = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef DEBUG
    dstLen <- length dst
    when (dstLen - dstOffset < len)
        $ error $ "unsafePutPtrN: dst overflow: start" ++ show dstOffset
            ++ " end " ++ show dstLen ++ " len " ++ show len
#endif
    let !dstAddr# :: Addr#
dstAddr# = ByteArray# -> Addr#
byteArrayContents# (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# (MutByteArray -> MutableByteArray# RealWorld
getMutByteArray# MutByteArray
dst))
        !(I# Int#
dstOff#) = Int
dstOffset
        !dstAddr1# :: Addr#
dstAddr1# = Addr# -> Int# -> Addr#
plusAddr# Addr#
dstAddr# Int#
dstOff#
    Ptr Word8
_ <- Addr# -> Addr# -> CSize -> IO (Ptr Word8)
c_memcpy_pinned Addr#
dstAddr1# Addr#
srcAddr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Unsafe as it does not check whether the start offset and length supplied
-- are valid inside the array.
{-# INLINE unsafeCloneSliceAs #-}
cloneSliceUnsafeAs, unsafeCloneSliceAs :: MonadIO m =>
    PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSliceAs :: forall (m :: * -> *).
MonadIO m =>
PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSliceAs PinnedState
ps Int
srcOff Int
srcLen MutByteArray
src =
    IO MutByteArray -> m MutByteArray
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MutByteArray -> m MutByteArray)
-> IO MutByteArray -> m MutByteArray
forall a b. (a -> b) -> a -> b
$ do
        MutByteArray
mba <- PinnedState -> Int -> IO MutByteArray
newAs PinnedState
ps Int
srcLen
        MutByteArray -> Int -> MutByteArray -> Int -> Int -> IO ()
forall (m :: * -> *).
MonadIO m =>
MutByteArray -> Int -> MutByteArray -> Int -> Int -> m ()
unsafePutSlice MutByteArray
src Int
srcOff MutByteArray
mba Int
0 Int
srcLen
        MutByteArray -> IO MutByteArray
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MutByteArray
mba

-- | @unsafeCloneSlice offset len arr@ clones a slice of the supplied array
-- starting at the given offset and equal to the given length.
{-# INLINE unsafeCloneSlice #-}
cloneSliceUnsafe, unsafeCloneSlice :: MonadIO m => Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSlice :: forall (m :: * -> *).
MonadIO m =>
Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSlice = PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
forall (m :: * -> *).
MonadIO m =>
PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSliceAs PinnedState
Unpinned

-- | @unsafePinnedCloneSlice offset len arr@
{-# INLINE unsafePinnedCloneSlice #-}
pinnedCloneSliceUnsafe, unsafePinnedCloneSlice :: MonadIO m =>
    Int -> Int -> MutByteArray -> m MutByteArray
unsafePinnedCloneSlice :: forall (m :: * -> *).
MonadIO m =>
Int -> Int -> MutByteArray -> m MutByteArray
unsafePinnedCloneSlice = PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
forall (m :: * -> *).
MonadIO m =>
PinnedState -> Int -> Int -> MutByteArray -> m MutByteArray
unsafeCloneSliceAs PinnedState
Pinned

unsafeByteCmp
    :: MutByteArray -> Int -> MutByteArray -> Int -> Int -> IO Int
unsafeByteCmp :: MutByteArray -> Int -> MutByteArray -> Int -> Int -> IO Int
unsafeByteCmp
    (MutByteArray MutableByteArray# RealWorld
marr1) (I# Int#
st1#) (MutByteArray MutableByteArray# RealWorld
marr2) (I# Int#
st2#) (I# Int#
len#) =
    (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# ->
        let res :: Int
res =
                Int# -> Int
I#
                    (ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
compareByteArrays#
                         (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# MutableByteArray# RealWorld
marr1)
                         Int#
st1#
                         (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# MutableByteArray# RealWorld
marr2)
                         Int#
st2#
                         Int#
len#)
         in (# State# RealWorld
s#, Int
res #)

-------------------------------------------------------------------------------
-- Pinning & Unpinning
-------------------------------------------------------------------------------

-- | Return 'True' if the array is allocated in pinned memory.
{-# INLINE isPinned #-}
isPinned :: MutByteArray -> Bool
isPinned :: MutByteArray -> Bool
isPinned (MutByteArray MutableByteArray# RealWorld
arr#) =
    let pinnedInt :: Int
pinnedInt = Int# -> Int
I# (MutableByteArray# RealWorld -> Int#
forall d. MutableByteArray# d -> Int#
isMutableByteArrayPinned# MutableByteArray# RealWorld
arr#)
     in Int
pinnedInt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0


{-# INLINE cloneMutableArrayWith# #-}
cloneMutableArrayWith#
    :: (Int# -> State# RealWorld -> (# State# RealWorld
                                     , MutableByteArray# RealWorld #))
    -> MutableByteArray# RealWorld
    -> State# RealWorld
    -> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# :: (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
alloc# MutableByteArray# RealWorld
arr# State# RealWorld
s# =
    case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, Int# #)
forall d. MutableByteArray# d -> State# d -> (# State# d, Int# #)
getSizeofMutableByteArray# MutableByteArray# RealWorld
arr# State# RealWorld
s# of
        (# State# RealWorld
s1#, Int#
i# #) ->
            case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
alloc# Int#
i# State# RealWorld
s1# of
                (# State# RealWorld
s2#, MutableByteArray# RealWorld
arr1# #) ->
                    case MutableByteArray# RealWorld
-> Int#
-> MutableByteArray# RealWorld
-> Int#
-> Int#
-> State# RealWorld
-> State# RealWorld
forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray# MutableByteArray# RealWorld
arr# Int#
0# MutableByteArray# RealWorld
arr1# Int#
0# Int#
i# State# RealWorld
s2# of
                        State# RealWorld
s3# -> (# State# RealWorld
s3#, MutableByteArray# RealWorld
arr1# #)

-- | Return a copy of the array in pinned memory if unpinned, else return the
-- original array.
{-# INLINE pin #-}
pin :: MutByteArray -> IO MutByteArray
pin :: MutByteArray -> IO MutByteArray
pin arr :: MutByteArray
arr@(MutByteArray MutableByteArray# RealWorld
marr#) =
    if MutByteArray -> Bool
isPinned MutByteArray
arr
    then MutByteArray -> IO MutByteArray
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MutByteArray
arr
    else
#ifdef DEBUG
      do
        -- XXX dump stack trace
        trace ("pin: Copying array") (return ())
#endif
        (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
             ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# ->
                   case (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# MutableByteArray# RealWorld
marr# State# RealWorld
s# of
                       (# State# RealWorld
s1#, MutableByteArray# RealWorld
marr1# #) -> (# State# RealWorld
s1#, MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
marr1# #)

-- | Return a copy of the array in unpinned memory if pinned, else return the
-- original array.
{-# INLINE unpin #-}
unpin :: MutByteArray -> IO MutByteArray
unpin :: MutByteArray -> IO MutByteArray
unpin arr :: MutByteArray
arr@(MutByteArray MutableByteArray# RealWorld
marr#) =
    if Bool -> Bool
not (MutByteArray -> Bool
isPinned MutByteArray
arr)
    then MutByteArray -> IO MutByteArray
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MutByteArray
arr
    else
#ifdef DEBUG
      do
        -- XXX dump stack trace
        trace ("unpin: Copying array") (return ())
#endif
        (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
             ((State# RealWorld -> (# State# RealWorld, MutByteArray #))
 -> IO MutByteArray)
-> (State# RealWorld -> (# State# RealWorld, MutByteArray #))
-> IO MutByteArray
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# ->
                   case (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# MutableByteArray# RealWorld
marr# State# RealWorld
s# of
                       (# State# RealWorld
s1#, MutableByteArray# RealWorld
marr1# #) -> (# State# RealWorld
s1#, MutableByteArray# RealWorld -> MutByteArray
MutByteArray MutableByteArray# RealWorld
marr1# #)

--------------------------------------------------------------------------------
-- Renaming
--------------------------------------------------------------------------------

RENAME(getMutableByteArray#, getMutByteArray#)
RENAME(newBytesAs, newAs)
RENAME(sizeOfMutableByteArray, length)
RENAME(putSliceUnsafe, unsafePutSlice)
RENAME(cloneSliceUnsafeAs, unsafeCloneSliceAs)
RENAME(cloneSliceUnsafe, unsafeCloneSlice)
RENAME(pinnedCloneSliceUnsafe, unsafePinnedCloneSlice)