{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}
{-# LANGUAGE MagicHash    #-}

module HsForeign.Primitive
  ( BA# (BA#)
  , MBA# (MBA#)
  , BAArray# (BAArray#)
  , withPrim, allocPrim
  , withPrimUnsafe
  , allocPrimUnsafe
  , withPrimArray
  , withPrimList
  , allocPrimArray
  , withPrimArrayUnsafe
  , allocPrimArrayUnsafe
  , withPrimArrayList
  , withPrimArrayListUnsafe
  , withForeignPtrList

    -- * Internal helpers
  , withMutablePrimArrayContents
  , withPrimArrayContents
  , byteArrayContents#
  , mutableByteArrayContents#

    -- * Re-export
  , module Data.Primitive
  , module Control.Monad.Primitive
  ) where

import           Control.Monad                 (foldM_)
import           Control.Monad.Primitive
import           Data.Primitive
import           Data.Primitive.Unlifted.Array
import           Foreign.ForeignPtr
import           GHC.Exts

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

newtype BA# a = BA# ByteArray#
newtype MBA# a = MBA# (MutableByteArray# RealWorld)
newtype BAArray# a = BAArray# ArrayArray#

-- From Z-Data package: Z.Foreign
--
-- | 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>.
withPrim :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b)
withPrim :: a -> (Ptr a -> IO b) -> IO (a, b)
withPrim a
v Ptr a -> IO b
f = do
  MutablePrimArray RealWorld a
buf <- Int -> IO (MutablePrimArray (PrimState IO) a)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newAlignedPinnedPrimArray Int
1
  MutablePrimArray (PrimState IO) a -> Int -> a -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
buf Int
0 a
v
  !b
b <- MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \ Ptr a
ptr -> Ptr a -> IO b
f Ptr a
ptr
  !a
a <- MutablePrimArray (PrimState IO) a -> Int -> IO a
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
buf Int
0
  (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)
{-# INLINABLE withPrim #-}

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

-- From Z-Data package: Z.Foreign
--
-- | 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 SYNC FFI CALL ONLY.
withPrimUnsafe :: (Prim a) => a -> (MBA# a -> IO b) -> IO (a, b)
withPrimUnsafe :: a -> (MBA# a -> IO b) -> IO (a, b)
withPrimUnsafe a
v MBA# a -> IO b
f = do
  -- All heap objects are WORD aligned so no need to do extra alignment
  mpa :: MutablePrimArray RealWorld a
mpa@(MutablePrimArray MutableByteArray# RealWorld
mba#) <- Int -> IO (MutablePrimArray (PrimState IO) a)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
1
  MutablePrimArray (PrimState IO) a -> Int -> a -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
mpa Int
0 a
v
  !b
b <- MBA# a -> IO b
f (MutableByteArray# RealWorld -> MBA# a
forall a. MutableByteArray# RealWorld -> MBA# a
MBA# MutableByteArray# RealWorld
mba#)
  !a
a <- MutablePrimArray (PrimState IO) a -> Int -> IO a
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
mpa Int
0
  (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)
{-# INLINE withPrimUnsafe #-}

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

-- From Z-Data package: Z.Foreign
--
-- | 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>.
withPrimArray :: (Prim a) => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray :: PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray PrimArray a
arr Ptr a -> Int -> IO b
f
  | PrimArray a -> Bool
forall a. PrimArray a -> Bool
isPrimArrayPinned PrimArray a
arr = do
      let siz :: Int
siz = PrimArray a -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
arr
      PrimArray a -> (Ptr a -> IO b) -> IO b
forall a b. PrimArray a -> (Ptr a -> IO b) -> IO b
withPrimArrayContents PrimArray a
arr ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
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 = PrimArray a -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
arr
      MutablePrimArray RealWorld a
buf <- Int -> IO (MutablePrimArray (PrimState IO) a)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
siz
      MutablePrimArray (PrimState IO) a
-> Int -> PrimArray a -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld a
MutablePrimArray (PrimState IO) a
buf Int
0 PrimArray a
arr Int
0 Int
siz
      MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
forall a b. MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents MutablePrimArray RealWorld a
buf ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> Ptr a -> Int -> IO b
f Ptr a
ptr Int
siz
{-# INLINABLE withPrimArray #-}

withPrimList :: Prim a => [a] -> (Ptr a -> Int -> IO b) -> IO b
withPrimList :: [a] -> (Ptr a -> Int -> IO b) -> IO b
withPrimList = PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray (PrimArray a -> (Ptr a -> Int -> IO b) -> IO b)
-> ([a] -> PrimArray a) -> [a] -> (Ptr a -> Int -> IO b) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> PrimArray a
forall a. Prim a => [a] -> PrimArray a
primArrayFromList
{-# INLINABLE withPrimList #-}

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

-- From Z-Data package: Z.Foreign
--
-- | 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 SYNC FFI CALL ONLY.
withPrimArrayUnsafe :: (Prim a) => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe :: PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe pa :: PrimArray a
pa@(PrimArray ByteArray#
ba#) BA# a -> Int -> IO b
f = BA# a -> Int -> IO b
f (ByteArray# -> BA# a
forall a. ByteArray# -> BA# a
BA# ByteArray#
ba#) (PrimArray a -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray a
pa)
{-# INLINE withPrimArrayUnsafe #-}

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

-- From Z-Data package: Z.Foreign
--
-- | 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>.
withPrimArrayList
  :: Prim a => [PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withPrimArrayList :: [PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withPrimArrayList [PrimArray a]
pas0 Ptr (Ptr a) -> Int -> IO b
f = do
  let l :: Int
l = [PrimArray a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimArray a]
pas0
  MutablePrimArray RealWorld (Ptr a)
ptrs <- Int -> IO (MutablePrimArray (PrimState IO) (Ptr a))
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 <- MutablePrimArray (PrimState IO) (Ptr a) -> IO (PrimArray (Ptr a))
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
MutablePrimArray (PrimState IO) (Ptr a)
ptrs
                       PrimArray (Ptr a) -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray 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 'withPrimArray' calls to keep all pointers alive
      PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray PrimArray a
pa ((Ptr a -> Int -> IO b) -> IO b) -> (Ptr a -> Int -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \ Ptr a
ppa Int
_ -> do
        MutablePrimArray (PrimState IO) (Ptr a) -> Int -> Ptr a -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
MutablePrimArray (PrimState IO) (Ptr a)
ptrs Int
i Ptr a
ppa
        MutablePrimArray RealWorld (Ptr a) -> Int -> [PrimArray a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [PrimArray a]
pas
{-# INLINABLE withPrimArrayList #-}

withForeignPtrList :: [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withForeignPtrList :: [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
withForeignPtrList [ForeignPtr a]
fptrs Ptr (Ptr a) -> Int -> IO b
f = do
  let l :: Int
l = [ForeignPtr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ForeignPtr a]
fptrs
  MutablePrimArray RealWorld (Ptr a)
ptrs <- Int -> IO (MutablePrimArray (PrimState IO) (Ptr a))
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
l
  MutablePrimArray RealWorld (Ptr a) -> Int -> [ForeignPtr a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs Int
0 [ForeignPtr a]
fptrs
  where
    go :: MutablePrimArray RealWorld (Ptr a) -> Int -> [ForeignPtr a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs !Int
_ [] = do
      PrimArray (Ptr a)
pa <- MutablePrimArray (PrimState IO) (Ptr a) -> IO (PrimArray (Ptr a))
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld (Ptr a)
MutablePrimArray (PrimState IO) (Ptr a)
ptrs
      PrimArray (Ptr a) -> (Ptr (Ptr a) -> Int -> IO b) -> IO b
forall a b. Prim a => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b
withPrimArray PrimArray (Ptr a)
pa Ptr (Ptr a) -> Int -> IO b
f
    go MutablePrimArray RealWorld (Ptr a)
ptrs !Int
i (ForeignPtr a
fp:[ForeignPtr a]
fps) = do
      ForeignPtr a -> (Ptr a -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fp ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr a
p -> do
        MutablePrimArray (PrimState IO) (Ptr a) -> Int -> Ptr a -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld (Ptr a)
MutablePrimArray (PrimState IO) (Ptr a)
ptrs Int
i Ptr a
p
        MutablePrimArray RealWorld (Ptr a) -> Int -> [ForeignPtr a] -> IO b
go MutablePrimArray RealWorld (Ptr a)
ptrs (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [ForeignPtr a]
fps

-- From Z-Data package: Z.Foreign, with slight modification.
--
-- | 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.
--
-- 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
withPrimArrayListUnsafe :: [PrimArray a] -> (BAArray# a -> Int -> IO b) -> IO b
withPrimArrayListUnsafe [PrimArray a]
pas BAArray# a -> Int -> IO b
f = do
  let l :: Int
l = [PrimArray a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimArray a]
pas
  MutableUnliftedArray_ RealWorld (PrimArray a) ByteArray#
mla <- Int -> IO (MutableUnliftedArray (PrimState IO) (PrimArray a))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MutableUnliftedArray (PrimState m) a)
unsafeNewUnliftedArray Int
l
  (Int -> PrimArray a -> IO Int) -> Int -> [PrimArray a] -> IO ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\ !Int
i PrimArray a
pa -> MutableUnliftedArray (PrimState IO) (PrimArray a)
-> Int -> PrimArray a -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, PrimUnlifted a) =>
MutableUnliftedArray (PrimState m) a -> Int -> a -> m ()
writeUnliftedArray MutableUnliftedArray_ RealWorld (PrimArray a) ByteArray#
MutableUnliftedArray (PrimState IO) (PrimArray a)
mla Int
i PrimArray a
pa IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Int
0 [PrimArray a]
pas
  (UnliftedArray UnliftedArray# ByteArray#
la#) <- MutableUnliftedArray (PrimState IO) (PrimArray a)
-> IO (UnliftedArray (PrimArray a))
forall (m :: * -> *) a.
PrimMonad m =>
MutableUnliftedArray (PrimState m) a -> m (UnliftedArray a)
unsafeFreezeUnliftedArray MutableUnliftedArray_ RealWorld (PrimArray a) ByteArray#
MutableUnliftedArray (PrimState IO) (PrimArray a)
mla
  BAArray# a -> Int -> IO b
f (ArrayArray# -> BAArray# a
forall a. ArrayArray# -> BAArray# a
BAArray# (UnliftedArray# ByteArray# -> ArrayArray#
unsafeCoerce# UnliftedArray# ByteArray#
la#)) Int
l
{-# INLINE withPrimArrayListUnsafe #-}

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

#if __GLASGOW_HASKELL__ < 902
-- ghc<9.2 does not has a 'mutableByteArrayContents#'
mutableByteArrayContents# :: MutableByteArray# s -> Addr#
mutableByteArrayContents# :: MutableByteArray# s -> Addr#
mutableByteArrayContents# MutableByteArray# s
mba# = ByteArray# -> Addr#
byteArrayContents# (MutableByteArray# s -> ByteArray#
unsafeCoerce# MutableByteArray# s
mba#)
{-# INLINE mutableByteArrayContents# #-}
#endif

-- From Z-Data package
--
-- | Obtain the pointer to the content of an mutable array, and the pointer
-- should only be used during the IO action.
--
-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated
-- by 'newPinnedPrimArray' or 'newAlignedPinnedPrimArray').
--
-- Don't pass a forever loop to this function,
-- see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withMutablePrimArrayContents
  :: MutablePrimArray RealWorld a
  -> (Ptr a -> IO b)
  -> IO b
withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b
withMutablePrimArrayContents (MutablePrimArray MutableByteArray# RealWorld
mba#) Ptr a -> IO b
f = do
    let addr# :: Addr#
addr# = MutableByteArray# RealWorld -> Addr#
forall s. MutableByteArray# s -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
mba#
        ptr :: Ptr a
ptr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr#
    b
b <- Ptr a -> IO b
f Ptr a
forall a. Ptr a
ptr
    (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (MutableByteArray# RealWorld -> State# RealWorld -> State# RealWorld
forall k1. k1 -> State# RealWorld -> State# RealWorld
touch# MutableByteArray# RealWorld
mba#)
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE withMutablePrimArrayContents #-}

-- From Z-Data package
--
-- | Obtain the pointer to the content of an array, and the pointer should only
-- be used during the IO action.
--
-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated
-- by 'newPinnedPrimArray' or 'newAlignedPinnedPrimArray').
--
-- Don't pass a forever loop to this function,
-- see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.
withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b
withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b
withPrimArrayContents (PrimArray ByteArray#
ba#) Ptr a -> IO b
f = do
    let addr# :: Addr#
addr# = ByteArray# -> Addr#
byteArrayContents# ByteArray#
ba#
        ptr :: Ptr a
ptr = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr#
    b
b <- Ptr a -> IO b
f Ptr a
forall a. Ptr a
ptr
    (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ (ByteArray# -> State# RealWorld -> State# RealWorld
forall k1. k1 -> State# RealWorld -> State# RealWorld
touch# ByteArray#
ba#)
    b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
{-# INLINE withPrimArrayContents #-}