{-|
Module      : Z.Foreign
Description : Use PrimArray \/ PrimVector with FFI
Copyright   : (c) Dong Han, 2017-2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provide functions for using 'PrimArray' and 'PrimVector' with GHC FFI(Foreign function interface),
Some functions are designed to be used with <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/ffi-chap.html#unlifted-ffi-types UnliftedFFITypes> extension.

GHC runtime is garbaged collected, there're two types of primitive array in GHC, with the objective to minimize overall memory management cost:

  * Small primitive arrays created with 'newPrimArray' are directly allocated on GHC heap, which can be moved
    by GHC garbage collector, we call these arrays @unpinned@. Allocating these array is cheap, we only need
    to check heap limit and bump heap pointer just like any other haskell heap objects. But we will pay GC cost
    , which is OK for small arrays.

  * Large primitive array and those created with 'newPinnedPrimArray' are allocated on GHC managed memory blocks,
    which is also traced by garbage collector, but will never moved before freed, thus are called @pinned@.
    Allocating these arrays are bit more expensive since it's more like how @malloc@ works, but we don't have to
    pay for GC cost.

Beside the @pinned/unpinned@ difference, we have two types of FFI calls in GHC:

  * Safe FFI call annotated with @safe@ keyword. These calls are executed on separated OS thread, which can be
    running concurrently with GHC garbage collector, thus we want to make sure only pinned arrays are passed.
    The main use case for @safe@ FFIs are long running functions, for example, doing IO polling.
    Since these calls are running on separated OS thread, haskell thread on original OS thread will not be affected.

  * Unsafe FFI call annotated with @unsafe@ keyword. These calls are executed on the same OS thread which is
    running the haskell side FFI code, which will in turn stop GHC from doing a garbage collection. We can pass
    both 'pinned' and 'unpinned' arrays in this case. The use case for @unsafe@ FFIs are short/small functions,
    which can be treated like a fat primitive operations, such as @memcpy@, @memcmp@. Using @unsafe@ FFI with
    long running functions will effectively block GHC runtime thread from running any other haskell threads, which
    is dangerous. Even if you use threaded runtime and expect your haskell thread can be stolen by other OS threads,
    but this will not work since GHC garbage collector will refuse to run if one of the OS thread is blocked by
    FFI calls.

Base on above analysis, we have following FFI strategy table.

  +--------------+---------------+---------------+
  | FFI  \ Array |    pinned     |   unpinned    |
  +--------------+---------------+---------------+
  |   unsafe     | directly pass | directly pass |
  +--------------+---------------+---------------+
  |     safe     | directly pass |  make a copy  |
  +--------------+---------------+---------------+

In this module, we separate safe and unsafe FFI handling due to the strategy difference: if the user can guarantee
a FFI call is unsafe, we can save an extra copy and pinned allocation. Mistakenly using unsafe function with safe FFI
will result in segfault.

-}

module Z.Foreign
  ( -- ** Unsafe FFI
    withPrimArrayUnsafe
  , allocPrimArrayUnsafe
  , withPrimVectorUnsafe
  , allocPrimVectorUnsafe
  , allocBytesUnsafe
  , withPrimUnsafe
  , allocPrimUnsafe
  , withPrimArrayListUnsafe
    -- ** Safe FFI
  , withPrimArraySafe
  , allocPrimArraySafe
  , withPrimVectorSafe
  , allocPrimVectorSafe
  , allocBytesSafe
  , withPrimSafe
  , allocPrimSafe
  , withPrimArrayListSafe
  , pinPrimArray
  , pinPrimVector
    -- ** Pointer helpers
  , BA# (..), MBA# (..), BAArray# (..)
  , clearMBA
  , clearPtr
  , castPtr
  , fromNullTerminated, fromPtr, fromPrimPtr
  , StdString, fromStdString
  -- ** convert between bytestring
  , fromByteString
  , toByteString
  -- ** re-export
  , RealWorld
  , touch
  , module Data.Primitive.ByteArray
  , module Data.Primitive.PrimArray
  , module Foreign.C.Types
  , module Data.Primitive.Ptr
  , module Z.Data.Array.Unaligned
  , withMutablePrimArrayContents, withPrimArrayContents
  -- ** Internal helpers
  , hs_std_string_size
  , hs_copy_std_string
  , hs_delete_std_string
  ) where

import           Control.Exception              (bracket)
import           Control.Monad
import           Control.Monad.Primitive
import           Data.ByteString                (ByteString)
import qualified Data.ByteString                as B
import           Data.ByteString.Short.Internal (ShortByteString (..),
                                                 fromShort, toShort)
import qualified Data.ByteString.Unsafe         as B
import qualified Data.List                      as List
import           Data.Primitive
import           Data.Primitive.ByteArray
import           Data.Primitive.PrimArray
import           Data.Primitive.Ptr
import           Data.Word
import           Foreign.C.Types
import           GHC.Exts
import           GHC.Ptr
import           Z.Data.Array.Base              (withMutablePrimArrayContents,
                                                 withPrimArrayContents)
import           Z.Data.Array.Unaligned
import           Z.Data.Array.UnliftedArray
import           Z.Data.Vector.Base

-- | Type alias for 'ByteArray#'.
--
-- Describe a 'ByteArray#' which we are going to pass across FFI. Use this type with @UnliftedFFITypes@
-- extension, At C side you should use a proper const pointer type.
--
-- Don't cast 'BA#' to 'Addr#' since the heap object offset is hard-coded in code generator:
-- <https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Foreign.hs#L542 Note [Unlifted boxed arguments to foreign calls]>
--
-- In haskell side we use type system to distinguish immutable / mutable arrays, but in C side we can't.
-- So it's users' responsibility to make sure the array content is not mutated (a const pointer type may help).
--
-- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'ByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL.
type BA# a = ByteArray#
pattern BA# :: ByteArray# -> BA# a
pattern $bBA# :: forall {k} (a :: k). BA# a -> BA# a
$mBA# :: forall {r} {k} {a :: k}. BA# a -> (BA# a -> r) -> ((# #) -> r) -> r
BA# ba = ba

-- | Type alias for 'MutableByteArray#' 'RealWorld'.
--
-- Describe a 'MutableByteArray#' which we are going to pass across FFI. Use this type with @UnliftedFFITypes@
-- extension, At C side you should use a proper pointer type.
--
-- Don't cast 'MBA#' to 'Addr#' since the heap object offset is hard-coded in code generator:
-- <https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Foreign.hs#L542 Note [Unlifted boxed arguments to foreign calls]>
--
-- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'MutableByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL.
type MBA# a = MutableByteArray# RealWorld
pattern MBA# :: MutableByteArray# RealWorld -> MBA# a
pattern $bMBA# :: forall {k} (a :: k). MBA# a -> MBA# a
$mMBA# :: forall {r} {k} {a :: k}.
MBA# a -> (MBA# a -> r) -> ((# #) -> r) -> r
MBA# mba = mba

-- | Type alias for 'ArrayArray#'.
--
-- Describe a array of 'ByteArray#' which we are going to pass across FFI. Use this type with @UnliftedFFITypes@
-- extension, At C side you should use @StgArrBytes**@(>=8.10) or @StgMutArrPtrs*@(<8.10) type from "Rts.h",
-- example code modified from
-- <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/ffi-chap.html#unlifted-ffi-types GHC manual>:
--
-- @
-- \/\/ C source, must include the RTS to make the struct StgArrBytes
-- \/\/ available along with its fields: ptrs and payload.
-- #include "Rts.h"
-- // GHC 8.10 changes the way how ArrayArray# is passed to C, so...
-- #if \_\_GLASGOW_HASKELL\_\_ < 810
-- HsInt sum_first (StgMutArrPtrs *arr, HsInt len) {
--   StgArrBytes **bufs = (StgArrBytes**)arr->payload;
-- #else
-- HsInt sum_first (StgArrBytes **bufs, HsInt len) {
-- #endif
--   int res = 0;
--   for(StgWord ix = 0;ix < len;ix++) {
--      // payload pointer type is StgWord*, cast it before use!
--      res = res + ((HsInt*)(bufs[ix]->payload))[0];
--   }
--   return res;
-- }
--
-- -- Haskell source, all elements in the argument array must be
-- -- either ByteArray\# or MutableByteArray\#. This is not enforced
-- -- by the type system in this example since ArrayArray is untyped.
-- foreign import ccall unsafe "sum_first" sumFirst :: BAArray# Int -> Int -> IO CInt
-- @
type BAArray# a = ArrayArray#
pattern BAArray# :: ArrayArray# -> BAArray# a
pattern $bBAArray# :: forall {k} (a :: k). BAArray# a -> BAArray# a
$mBAArray# :: forall {r} {k} {a :: k}.
BAArray# a -> (BAArray# a -> r) -> ((# #) -> r) -> r
BAArray# baa = baa

-- | Clear 'MBA#' with given length to zero.
clearMBA :: MBA# a
         -> Int  -- ^ in bytes
         -> IO ()
{-# INLINE clearMBA #-}
clearMBA :: forall {k} (a :: k). MBA# a -> Int -> IO ()
clearMBA (MBA# MBA# a
mba#) Int
len =
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> Int -> a -> m ()
setByteArray (forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MBA# a
mba#) Int
0 Int
len (Word8
0 :: Word8)

-- | Pass primitive array to unsafe FFI as pointer.
--
-- Enable 'UnliftedFFITypes' extension in your haskell code, use proper pointer type and @HsInt@
-- to marshall @ByteArray#@ and @Int@ arguments on C side.
--
-- The second 'Int' arguement is the element size not the bytes size.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
withPrimArrayUnsafe :: (Prim a) => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
{-# INLINE withPrimArrayUnsafe #-}
withPrimArrayUnsafe :: forall a b. Prim a => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe pa :: PrimArray a
pa@(PrimArray BA# a
ba#) BA# a -> Int -> IO b
f = BA# a -> Int -> IO b
f (forall {k} (a :: k). BA# a -> BA# a
BA# BA# a
ba#) (forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
pa)

-- | Pass primitive array list to unsafe FFI as @StgArrBytes**@.
--
-- Enable 'UnliftedFFITypes' extension in your haskell code, use @StgArrBytes**@(>=8.10)
-- or @StgMutArrPtrs*@(<8.10) pointer type and @HsInt@
-- to marshall @BAArray#@ and @Int@ arguments on C side, check the example with 'BAArray#'.
--
-- The second 'Int' arguement is the list size.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
withPrimArrayListUnsafe :: [PrimArray a] -> (BAArray# a -> Int -> IO b) -> IO b
{-# INLINE withPrimArrayListUnsafe #-}
withPrimArrayListUnsafe :: forall a b. [PrimArray a] -> (BAArray# a -> Int -> IO b) -> IO b
withPrimArrayListUnsafe [PrimArray a]
pas BAArray# a -> Int -> IO b
f = do
    let l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [PrimArray a]
pas
    MutableUnliftedArray RealWorld (PrimArray a)
mla <- forall {k} (m :: * -> *) (a :: k).
PrimMonad m =>
Int -> m (MutableUnliftedArray (PrimState m) a)
unsafeNewUnliftedArray Int
l
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\ !Int
i PrimArray a
pa -> forall (m :: * -> *) a.
(PrimMonad m, PrimUnlifted a) =>
MutableUnliftedArray (PrimState m) a -> Int -> a -> m ()
writeUnliftedArray MutableUnliftedArray RealWorld (PrimArray a)
mla Int
i PrimArray a
pa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iforall a. Num a => a -> a -> a
+Int
1)) Int
0 [PrimArray a]
pas
    (UnliftedArray BAArray# a
la#) <- forall {k} (m :: * -> *) (a :: k).
PrimMonad m =>
MutableUnliftedArray (PrimState m) a -> m (UnliftedArray a)
unsafeFreezeUnliftedArray MutableUnliftedArray RealWorld (PrimArray a)
mla
    BAArray# a -> Int -> IO b
f (forall {k} (a :: k). BAArray# a -> BAArray# a
BAArray# BAArray# a
la#) Int
l

-- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimArray'.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
allocPrimArrayUnsafe :: forall a b. Prim a => Int -> (MBA# a -> IO b) -> IO (PrimArray a, b)
{-# INLINE allocPrimArrayUnsafe #-}
allocPrimArrayUnsafe :: forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe Int
len MBA# a -> IO b
f = do
    (mpa :: MutablePrimArray RealWorld a
mpa@(MutablePrimArray MBA# a
mba#) :: MutablePrimArray RealWorld a) <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    !b
r <- MBA# a -> IO b
f (forall {k} (a :: k). MBA# a -> MBA# a
MBA# MBA# a
mba#)
    !PrimArray a
pa <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
mpa
    forall (m :: * -> *) a. Monad m => a -> m a
return (PrimArray a
pa, b
r)

-- | Pass 'PrimVector' to unsafe FFI as pointer
--
-- The 'PrimVector' version of 'withPrimArrayUnsafe'.
--
-- The second 'Int' arguement is the first element offset, the third 'Int' argument is the
-- element length.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
--
withPrimVectorUnsafe :: (Prim a)
                     => PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
{-# INLINE withPrimVectorUnsafe #-}
withPrimVectorUnsafe :: forall a b.
Prim a =>
PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe (PrimVector PrimArray a
arr Int
s Int
l) BA# a -> Int -> Int -> IO b
f = forall a b. Prim a => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray a
arr forall a b. (a -> b) -> a -> b
$ \ BA# a
ba# Int
_ -> BA# a -> Int -> Int -> IO b
f BA# a
ba# Int
s Int
l

-- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
allocPrimVectorUnsafe :: forall a b. Prim a => Int  -- ^ number of elements
                      -> (MBA# a -> IO b) -> IO (PrimVector a, b)
{-# INLINE allocPrimVectorUnsafe #-}
allocPrimVectorUnsafe :: forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe Int
len MBA# a -> IO b
f = do
    (mpa :: MutablePrimArray RealWorld a
mpa@(MutablePrimArray MBA# a
mba#) :: MutablePrimArray RealWorld a) <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    !b
r <- MBA# a -> IO b
f (forall {k} (a :: k). MBA# a -> MBA# a
MBA# MBA# a
mba#)
    !PrimArray a
pa <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
mpa
    let !v :: PrimVector a
v = forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray a
pa Int
0 Int
len
    forall (m :: * -> *) a. Monad m => a -> m a
return (PrimVector a
v, b
r)

-- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'Bytes'.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
allocBytesUnsafe :: Int  -- ^ number of bytes
                 -> (MBA# Word8 -> IO b) -> IO (Bytes, b)
{-# INLINE allocBytesUnsafe #-}
allocBytesUnsafe :: forall b. Int -> (MBA# a -> IO b) -> IO (Bytes, b)
allocBytesUnsafe = forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe

-- | Create an one element primitive array and use it as a pointer to the primitive element.
--
-- Return the element and the computation result.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
--
withPrimUnsafe :: (Prim a)
               => a -> (MBA# a -> IO b) -> IO (a, b)
{-# INLINE withPrimUnsafe #-}
withPrimUnsafe :: forall a b. Prim a => a -> (MBA# a -> IO b) -> IO (a, b)
withPrimUnsafe a
v MBA# a -> IO b
f = do
    mpa :: MutablePrimArray RealWorld a
mpa@(MutablePrimArray MBA# a
mba#) <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
1    -- All heap objects are WORD aligned
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
mpa Int
0 a
v
    !b
b <- MBA# a -> IO b
f (forall {k} (a :: k). MBA# a -> MBA# a
MBA# MBA# a
mba#)                              -- so no need to do extra alignment
    !a
a <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
mpa Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

-- | like 'withPrimUnsafe', but don't write initial value.
--
-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY.
allocPrimUnsafe :: (Prim a) => (MBA# a -> IO b) -> IO (a, b)
{-# INLINE allocPrimUnsafe #-}
allocPrimUnsafe :: forall a b. Prim a => (MBA# a -> IO b) -> IO (a, b)
allocPrimUnsafe MBA# a -> IO b
f = do
    mpa :: MutablePrimArray RealWorld a
mpa@(MutablePrimArray MBA# a
mba#) <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
1    -- All heap objects are WORD aligned
    !b
b <- MBA# a -> IO b
f (forall {k} (a :: k). MBA# a -> MBA# a
MBA# MBA# a
mba#)                              -- so no need to do extra alignment
    !a
a <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
mpa Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

--------------------------------------------------------------------------------

-- | Pass primitive array to safe FFI as pointer.
--
-- Use proper pointer type and @HsInt@ to marshall @Ptr a@ and @Int@ arguments on C side.
-- The memory pointed by 'Ptr a' will not moved during call. After call returned, pointer is no longer valid.
--
-- The second 'Int' arguement is the element size not the bytes size.
--
-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withPrimArraySafe :: (Prim a) => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
{-# INLINABLE withPrimArraySafe #-}
withPrimArraySafe :: forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArraySafe PrimArray a
arr Ptr a -> Int -> IO b
f
    | forall a. PrimArray a -> Bool
isPrimArrayPinned PrimArray a
arr = do
        let siz :: Int
siz = forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
arr
        forall a b. PrimArray a -> (Ptr a -> IO b) -> IO b
withPrimArrayContents PrimArray a
arr forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> Int -> IO b
f Ptr a
ptr Int
siz
    | Bool
otherwise = do
        let siz :: Int
siz = forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
arr
        MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
siz
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
buf Int
0 PrimArray a
arr Int
0 Int
siz
        forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> Int -> IO b
f Ptr a
ptr Int
siz

-- | Pass primitive array list to safe FFI as pointer.
--
-- Use proper pointer type and @HsInt@ to marshall @Ptr (Ptr a)@ and @Int@ arguments on C side.
-- The memory pointed by 'Ptr a' will not moved during call. After call returned, pointer is no longer valid.
--
-- The second 'Int' arguement is the list size.
--
-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withPrimArrayListSafe :: Prim a => [PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withPrimArrayListSafe :: forall a b.
Prim a =>
[PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withPrimArrayListSafe [PrimArray a]
pas0 Ptr (Ptr a) -> Int -> IO b
f = do
    let l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [PrimArray a]
pas0
    MutablePrimArray RealWorld (Ptr a)
ptrs <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
l
    MutablePrimArray RealWorld (Ptr a) -> Int -> [PrimArray a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs Int
0 [PrimArray a]
pas0
  where
    go :: MutablePrimArray RealWorld (Ptr a) -> Int -> [PrimArray a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs !Int
_ [] = do
        PrimArray (Ptr a)
pa <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
ptrs
        forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArraySafe PrimArray (Ptr a)
pa Ptr (Ptr a) -> Int -> IO b
f
    go MutablePrimArray RealWorld (Ptr a)
ptrs !Int
i (PrimArray a
pa:[PrimArray a]
pas) =
        -- It's important to nest 'withPrimArraySafe' calls to keep all pointers alive
        forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArraySafe PrimArray a
pa forall a b. (a -> b) -> a -> b
$ \ Ptr a
ppa Int
_ -> do
            forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
ptrs Int
i Ptr a
ppa
            MutablePrimArray RealWorld (Ptr a) -> Int -> [PrimArray a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs (Int
iforall a. Num a => a -> a -> a
+Int
1) [PrimArray a]
pas

-- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'.
allocPrimArraySafe :: forall a b . Prim a
                    => Int      -- ^ in elements
                    -> (Ptr a -> IO b)
                    -> IO (PrimArray a, b)
{-# INLINABLE allocPrimArraySafe #-}
allocPrimArraySafe :: forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO (PrimArray a, b)
allocPrimArraySafe Int
len Ptr a -> IO b
f = do
    MutablePrimArray RealWorld a
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newAlignedPinnedPrimArray Int
len
    !b
r <- forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
mpa Ptr a -> IO b
f
    !PrimArray a
pa <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
mpa
    forall (m :: * -> *) a. Monad m => a -> m a
return (PrimArray a
pa, b
r)

-- | Pass 'PrimVector' to safe FFI as pointer
--
-- The 'PrimVector' version of 'withPrimArraySafe'. The 'Ptr' is already pointed
-- to the first element, thus no offset is provided. After call returned, pointer is no longer valid.
--
-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withPrimVectorSafe :: forall a b. Prim a => PrimVector a -> (Ptr a -> Int -> IO b) -> IO b
{-# INLINABLE withPrimVectorSafe #-}
withPrimVectorSafe :: forall a b.
Prim a =>
PrimVector a -> (Ptr a -> Int -> IO b) -> IO b
withPrimVectorSafe (PrimVector PrimArray a
arr Int
s Int
l) Ptr a -> Int -> IO b
f
    | forall a. PrimArray a -> Bool
isPrimArrayPinned PrimArray a
arr =
        forall a b. PrimArray a -> (Ptr a -> IO b) -> IO b
withPrimArrayContents PrimArray a
arr forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr ->
            let ptr' :: Ptr a
ptr' = Ptr a
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
s forall a. Num a => a -> a -> a
* Int
siz) in Ptr a -> Int -> IO b
f Ptr a
ptr' Int
l
    | Bool
otherwise = do
        MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
l
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
buf Int
0 PrimArray a
arr Int
s Int
l
        forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> Int -> IO b
f Ptr a
ptr Int
l
  where
    siz :: Int
siz = forall a. Prim a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)

-- | Create an one element primitive array and use it as a pointer to the primitive element.
--
-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withPrimSafe :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b)
{-# INLINABLE withPrimSafe #-}
withPrimSafe :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b)
withPrimSafe a
v Ptr a -> IO b
f = do
    MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newAlignedPinnedPrimArray Int
1
    forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
buf Int
0 a
v
    !b
b <- forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> IO b
f Ptr a
ptr
    !a
a <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
buf Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

-- | like 'withPrimSafe', but don't write initial value.
allocPrimSafe :: forall a b. Prim a => (Ptr a -> IO b) -> IO (a, b)
{-# INLINABLE allocPrimSafe #-}
allocPrimSafe :: forall a b. Prim a => (Ptr a -> IO b) -> IO (a, b)
allocPrimSafe Ptr a -> IO b
f = do
    MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newAlignedPinnedPrimArray Int
1
    !b
b <- forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> IO b
f Ptr a
ptr
    !a
a <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
buf Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

-- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'.
allocPrimVectorSafe :: forall a b . Prim a
                    => Int      -- ^ in elements
                    -> (Ptr a -> IO b) -> IO (PrimVector a, b)
{-# INLINABLE allocPrimVectorSafe #-}
allocPrimVectorSafe :: forall a b.
Prim a =>
Int -> (Ptr a -> IO b) -> IO (PrimVector a, b)
allocPrimVectorSafe Int
len Ptr a -> IO b
f = do
    MutablePrimArray RealWorld a
mpa <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newAlignedPinnedPrimArray Int
len
    !b
r <- forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
mpa Ptr a -> IO b
f
    !PrimArray a
pa <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
mpa
    let !v :: PrimVector a
v = forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray a
pa Int
0 Int
len
    forall (m :: * -> *) a. Monad m => a -> m a
return (PrimVector a
v, b
r)

-- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimVector'.
allocBytesSafe :: Int      -- ^ in bytes
               -> (Ptr Word8 -> IO b) -> IO (Bytes, b)
{-# INLINABLE allocBytesSafe #-}
allocBytesSafe :: forall b. Int -> (Ptr Word8 -> IO b) -> IO (Bytes, b)
allocBytesSafe = forall a b.
Prim a =>
Int -> (Ptr a -> IO b) -> IO (PrimVector a, b)
allocPrimVectorSafe

-- | Convert a 'PrimArray' to a pinned one(memory won't moved by GC) if necessary.
pinPrimArray :: Prim a => PrimArray a -> IO (PrimArray a)
{-# INLINABLE pinPrimArray #-}
pinPrimArray :: forall a. Prim a => PrimArray a -> IO (PrimArray a)
pinPrimArray PrimArray a
arr
    | forall a. PrimArray a -> Bool
isPrimArrayPinned PrimArray a
arr = forall (m :: * -> *) a. Monad m => a -> m a
return PrimArray a
arr
    | Bool
otherwise = do
        let l :: Int
l = forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
arr
        MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
l
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
buf Int
0 PrimArray a
arr Int
0 Int
l
        PrimArray a
arr' <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
buf
        forall (m :: * -> *) a. Monad m => a -> m a
return PrimArray a
arr'

-- | Convert a 'PrimVector' to a pinned one(memory won't moved by GC) if necessary.
pinPrimVector :: Prim a => PrimVector a -> IO (PrimVector a)
{-# INLINABLE pinPrimVector #-}
pinPrimVector :: forall a. Prim a => PrimVector a -> IO (PrimVector a)
pinPrimVector v :: PrimVector a
v@(PrimVector PrimArray a
pa Int
s Int
l)
    | forall a. PrimArray a -> Bool
isPrimArrayPinned PrimArray a
pa = forall (m :: * -> *) a. Monad m => a -> m a
return PrimVector a
v
    | Bool
otherwise = do
        MutablePrimArray RealWorld a
buf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
l
        forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
buf Int
0 PrimArray a
pa Int
s Int
l
        PrimArray a
pa' <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
buf
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray a
pa' Int
0 Int
l)

--------------------------------------------------------------------------------

foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()

-- | Zero a structure.
--
-- There's no 'Storable' or 'Prim' constraint on 'a' type, the length
-- should be given in bytes.
--
clearPtr :: Ptr a -> Int -> IO ()
{-# INLINABLE clearPtr #-}
clearPtr :: forall a. Ptr a -> Int -> IO ()
clearPtr Ptr a
dest Int
nbytes = forall a. Ptr a -> CInt -> CSize -> IO ()
memset Ptr a
dest CInt
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nbytes)

-- | Copy some bytes from a null terminated pointer(without copying the null terminator).
--
-- You should consider using 'Z.Data.CBytes.CBytes' type for storing NULL terminated bytes first,
-- This method is provided if you really need to read 'Bytes', there's no encoding guarantee,
-- result could be any bytes sequence.
fromNullTerminated :: Ptr a -> IO Bytes
{-# INLINABLE fromNullTerminated #-}
fromNullTerminated :: forall a. Ptr a -> IO Bytes
fromNullTerminated (Ptr Addr#
addr#) = do
    Int
len <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr# -> IO CSize
c_strlen Addr#
addr#
    MutablePrimArray RealWorld Word8
marr <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m ()
copyPtrToMutablePrimArray MutablePrimArray RealWorld Word8
marr Int
0 (forall a. Addr# -> Ptr a
Ptr Addr#
addr#) Int
len
    PrimArray Word8
arr <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Word8
marr
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray Word8
arr Int
0 Int
len)

-- | Copy some bytes from a pointer.
--
-- There's no encoding guarantee, result could be any bytes sequence.
fromPtr :: Ptr a -> Int -- ^ in bytes
        -> IO Bytes
{-# INLINABLE fromPtr #-}
fromPtr :: forall a. Ptr a -> Int -> IO Bytes
fromPtr (Ptr Addr#
addr#) Int
len = do
    MutablePrimArray RealWorld Word8
marr <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m ()
copyPtrToMutablePrimArray MutablePrimArray RealWorld Word8
marr Int
0 (forall a. Addr# -> Ptr a
Ptr Addr#
addr#) Int
len
    PrimArray Word8
arr <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Word8
marr
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray Word8
arr Int
0 Int
len)

-- | Copy some bytes from a pointer.
--
-- There's no encoding guarantee, result could be any bytes sequence.
fromPrimPtr :: forall a. Prim a
            => Ptr a -> Int -- ^  in elements
            -> IO (PrimVector a)
{-# INLINABLE fromPrimPtr #-}
fromPrimPtr :: forall a. Prim a => Ptr a -> Int -> IO (PrimVector a)
fromPrimPtr (Ptr Addr#
addr#) Int
len = do
    MutablePrimArray RealWorld a
marr <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m ()
copyPtrToMutablePrimArray MutablePrimArray RealWorld a
marr Int
0 (forall a. Addr# -> Ptr a
Ptr Addr#
addr#) Int
len
    PrimArray a
arr <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld a
marr
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector PrimArray a
arr Int
0 Int
len)

-- | @std::string@ Pointer tag.
data StdString

-- | Run FFI in bracket and marshall @std::string*@ result into Haskell heap bytes,
-- memory pointed by @std::string*@ will be @delete@ ed.
fromStdString :: IO (Ptr StdString) -> IO Bytes
{-# INLINABLE fromStdString #-}
fromStdString :: IO (Ptr StdString) -> IO Bytes
fromStdString IO (Ptr StdString)
f = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Ptr StdString)
f Ptr StdString -> IO ()
hs_delete_std_string
    (\ Ptr StdString
q -> do
        Int
siz <- Ptr StdString -> IO Int
hs_std_string_size Ptr StdString
q
        (Bytes
bs,()
_) <- forall b. Int -> (MBA# a -> IO b) -> IO (Bytes, b)
allocBytesUnsafe Int
siz (Ptr StdString -> Int -> MBA# a -> IO ()
hs_copy_std_string Ptr StdString
q Int
siz)
        forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
bs)

foreign import ccall unsafe hs_std_string_size :: Ptr StdString -> IO Int
foreign import ccall unsafe hs_copy_std_string :: Ptr StdString -> Int -> MBA# Word8 -> IO ()
foreign import ccall unsafe hs_delete_std_string :: Ptr StdString -> IO ()

-- | O(n), Convert from 'ByteString'.
fromByteString :: ByteString -> Bytes
{-# INLINABLE fromByteString #-}
fromByteString :: ByteString -> Bytes
fromByteString ByteString
bs = case ByteString -> ShortByteString
toShort ByteString
bs of
    (SBS BA# a
ba#) -> forall a. PrimArray a -> Int -> Int -> PrimVector a
PrimVector (forall a. BA# a -> PrimArray a
PrimArray BA# a
ba#) Int
0 (ByteString -> Int
B.length ByteString
bs)

-- | O(n), Convert tp 'ByteString'.
toByteString :: Bytes -> ByteString
{-# INLINABLE toByteString #-}
toByteString :: Bytes -> ByteString
toByteString (PrimVector (PrimArray BA# a
ba#) Int
s Int
l) = Int -> ByteString -> ByteString
B.unsafeTake Int
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.unsafeDrop Int
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
fromShort forall a b. (a -> b) -> a -> b
$ BA# a -> ShortByteString
SBS BA# a
ba#