diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for Z-Data +## 0.1.7.2 -- 2020-10-17 + +* Add `withPrimArrayListUnsafe`, `withPrimArrayListSafe`, `withCBytesUnsafe`, `withCBytesListSafe`. + ## 0.1.7.1 -- 2020-10-17 * Add `singleton` to `Z.IO.CBytes`, fix `unpack` when there're trailing illegal UTF8 codepoints. diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.1.7.1 +version: 0.1.7.2 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -229,6 +229,8 @@ Z.Data.Vector.SortSpec Z.Data.Vector.FlatMapSpec Z.Data.Vector.FlatSetSpec + Z.ForeignSpec + build-depends: Z-Data , base , hspec >= 2.5.4 @@ -239,6 +241,8 @@ , word8 , scientific , primitive + + c-sources: test/cbits/ffi.c if flag(integer-simple) cpp-options: -DINTEGER_SIMPLE diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -23,6 +23,7 @@ , empty, singleton, append, concat, intercalate, intercalateElem , fromCString, fromCStringN , withCBytesUnsafe, withCBytes, allocCBytesUnsafe, allocCBytes + , withCBytesListUnsafe, withCBytesListSafe -- * re-export , CString , V.c2w, V.w2c @@ -530,12 +531,30 @@ {-# INLINABLE withCBytesUnsafe #-} withCBytesUnsafe (CBytes pa) f = withPrimArrayUnsafe pa (\ p _ -> f p) +-- | Pass 'CBytes' list to foreign function as a @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#'. +-- +-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. +withCBytesListUnsafe :: [CBytes] -> (BAArray# Word8 -> Int -> IO a) -> IO a +{-# INLINABLE withCBytesListUnsafe #-} +withCBytesListUnsafe pas = withPrimArrayListUnsafe (List.map rawPrimArray pas) + -- | Pass 'CBytes' to foreign function as a @const char*@. -- -- Don't pass a forever loop to this function, see . withCBytes :: CBytes -> (Ptr Word8 -> IO a) -> IO a {-# INLINABLE withCBytes #-} withCBytes (CBytes pa) f = withPrimArraySafe pa (\ p _ -> f p) + +-- | Pass 'CBytes' list to foreign function as a @const char**@. +-- +-- Check "Z.Foreign" module for more detail on how to marshall params in C side. +withCBytesListSafe :: [CBytes] -> (Ptr (Ptr Word8) -> Int -> IO a) -> IO a +{-# INLINABLE withCBytesListSafe #-} +withCBytesListSafe pas = withPrimArrayListSafe (List.map rawPrimArray pas) -- | Create a 'CBytes' with IO action. -- diff --git a/Z/Foreign.hs b/Z/Foreign.hs --- a/Z/Foreign.hs +++ b/Z/Foreign.hs @@ -7,10 +7,11 @@ Stability : experimental Portability : non-portable -This module provide functions for using 'PrimArray' and 'PrimVector' with GHC FFI(Foreign function interface). -Since GHC runtime is garbaged collected, we have a quite complex story when passing primitive arrays to FFI. -We have two types of primitive array in GHC, with the objective to minimize overall memory management cost: +This module provide functions for using 'PrimArray' and 'PrimVector' with GHC FFI(Foreign function interface), +Some functions are designed to be used with 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 @@ -21,7 +22,7 @@ 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 also have two types of FFI calls in GHC: +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. @@ -32,8 +33,8 @@ 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 thread, which - is dangerous. Even if you use threaded runtime and expect your haskell thread can be stolen by other OS thread, + 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. @@ -48,7 +49,7 @@ +--------------+---------------+---------------+ In this module, we separate safe and unsafe FFI handling due to the strategy difference: if the user can guarantee -the FFI are unsafe, we can save an extra copy and pinned allocation. Mistakenly using unsafe function with safe FFI +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. -} @@ -62,6 +63,7 @@ , allocBytesUnsafe , withPrimUnsafe , allocPrimUnsafe + , withPrimArrayListUnsafe -- ** Safe FFI , withPrimArraySafe , allocPrimArraySafe @@ -70,10 +72,11 @@ , allocBytesSafe , withPrimSafe , allocPrimSafe + , withPrimArrayListSafe , pinPrimArray , pinPrimVector -- ** Pointer helpers - , BA#, MBA# + , BA#, MBA#, BAArray# , clearMBA , clearPtr , castPtr @@ -86,16 +89,20 @@ , module Z.Data.Array.Unaligned ) where +import Control.Monad import Control.Monad.Primitive import Data.Primitive import Data.Word +import qualified Data.List as List import Data.Primitive.Ptr import Data.Primitive.ByteArray import Data.Primitive.PrimArray import Foreign.C.Types import GHC.Ptr +import GHC.Exts import Z.Data.Array import Z.Data.Array.Unaligned +import Z.Data.Array.UnliftedArray import Z.Data.Vector.Base -- | Type alias for 'ByteArray#'. @@ -104,7 +111,7 @@ -- 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: --- +-- -- -- 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). @@ -123,6 +130,42 @@ -- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'MutableByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. type MBA# a = MutableByteArray# RealWorld + + +-- | 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 +-- : +-- +-- @ +-- \/\/ 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_unsafe (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 -> IO CInt +-- @ +-- +type BAArray# a = ArrayArray# + -- | Clear 'MBA#' with given length to zero. clearMBA :: MBA# a -> Int -- ^ in bytes @@ -143,6 +186,23 @@ {-# INLINE withPrimArrayUnsafe #-} withPrimArrayUnsafe pa@(PrimArray ba#) f = f ba# (sizeofPrimArray 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 +withPrimArrayListUnsafe pas f = do + let l = List.length pas + mla <- unsafeNewUnliftedArray l + foldM_ (\ !i pa -> writeUnliftedArray mla i pa >> return (i+1)) 0 pas + (UnliftedArray la#) <- unsafeFreezeUnliftedArray mla + f la# l + -- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimArray'. -- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. @@ -190,7 +250,6 @@ allocBytesUnsafe = allocPrimVectorUnsafe - -- | Create an one element primitive array and use it as a pointer to the primitive element. -- -- Return the element and the computation result. @@ -239,6 +298,29 @@ buf <- newPinnedPrimArray siz copyPrimArray buf 0 arr 0 siz withMutablePrimArrayContents buf $ \ ptr -> f ptr 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 . +withPrimArrayListSafe :: Prim a => [PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b +withPrimArrayListSafe pas0 f = do + let l = List.length pas0 + ptrs <- newPinnedPrimArray l + go ptrs 0 pas0 + where + go ptrs !_ [] = do + pa <- unsafeFreezePrimArray ptrs + withPrimArraySafe pa f + go ptrs !i (pa:pas) = + -- It's important to nest 'withPrimArraySafe' calls to keep all pointers alive + withPrimArraySafe pa $ \ ppa _ -> do + writePrimArray ptrs i ppa + go ptrs (i+1) pas -- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'. allocPrimArraySafe :: forall a b . Prim a diff --git a/test/Z/ForeignSpec.hs b/test/Z/ForeignSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/ForeignSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.ForeignSpec where + +import qualified Data.List as List +import qualified Z.Data.CBytes as CB +import qualified Z.Data.JSON as JSON +import Z.Foreign +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Array as A +import Z.Foreign +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.Hspec +import Test.Hspec.QuickCheck +import System.IO.Unsafe + +spec :: Spec +spec = describe "Foreign" $ do + describe "pass prim array list to foreign" $ do + prop "sum first should be equal(unsafe FFI)" $ \ xss -> + let pas = List.map (V.pack . getNonEmpty) xss :: [A.PrimArray Int] + s = sum (List.map (List.head . getNonEmpty) xss) + in unsafeDupablePerformIO (withPrimArrayListUnsafe pas sum_first_unsafe) === s + + prop "sum first should be equal(safe FFI)" $ \ xss -> + let pas = List.map (V.pack . getNonEmpty) xss :: [A.PrimArray Int] + s = sum (List.map (List.head . getNonEmpty) xss) + in unsafeDupablePerformIO (withPrimArrayListSafe pas sum_first_safe) === s + +-------------------------------------------------------------------------------- + +foreign import ccall unsafe sum_first_unsafe :: BAArray# Int -> Int -> IO Int +foreign import ccall safe sum_first_safe :: Ptr (Ptr Int) -> Int -> IO Int diff --git a/test/cbits/ffi.c b/test/cbits/ffi.c new file mode 100644 --- /dev/null +++ b/test/cbits/ffi.c @@ -0,0 +1,23 @@ +#include "Rts.h" +#include "HsFFI.h" + +#if __GLASGOW_HASKELL__ < 810 +HsInt sum_first_unsafe (StgMutArrPtrs *arr, HsInt len) { + StgArrBytes **bufs = (StgArrBytes**)arr->payload; +#else +HsInt sum_first_unsafe (StgArrBytes **bufs, HsInt len) { +#endif + HsInt res = 0; + for(HsInt ix = 0;ix < len;ix++) { + res = res + ((HsInt*)(bufs[ix]->payload))[0]; + } + return res; +} + +HsInt sum_first_safe (HsInt** bufs, HsInt len) { + HsInt res = 0; + for(HsInt ix = 0;ix < len;ix++) { + res = res + bufs[ix][0]; + } + return res; +}