diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for foreign + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2022, mu +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# foreign + +A collection of data types, classes, and functions for easing your ffi +experience. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/foreign.cabal b/foreign.cabal new file mode 100644 --- /dev/null +++ b/foreign.cabal @@ -0,0 +1,77 @@ +cabal-version: 2.4 +name: foreign +version: 0.1.0.0 +synopsis: A collection of helpers for ffi. +description: + Please see the README on Github at + +license: BSD-3-Clause +license-file: LICENSE +copyright: Copyright (c) +author: mu +maintainer: mu@laxcat.xyz +tested-with: GHC ==8.10.7 +category: Foreign +homepage: https://github.com/4eUeP/foreign +bug-reports: https://github.com/4eUeP/foreign/issues +build-type: Simple +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/4eUeP/foreign + +common common + default-language: Haskell2010 + default-extensions: + DeriveGeneric + DerivingStrategies + EmptyDataDeriving + GADTSyntax + GeneralizedNewtypeDeriving + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + UnliftedFFITypes + UnliftedNewtypes + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + +library + import: common + hs-source-dirs: src + exposed-modules: + HsForeign + HsForeign.AsyncFFI + HsForeign.Primitive + + build-depends: + , base >=4.14 && <5 + , ghc-prim >=0.5 && <1.0 + , primitive ^>=0.7 + , primitive-unlifted ^>=1.0 + +test-suite foreign-test + import: common + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + HsForeign.AsyncFFISpec + HsForeign.PrimitiveSpec + + hs-source-dirs: test + c-sources: test/cbits/ffi.c + build-depends: + , base >=4.14 && <5 + , foreign + , hspec + , QuickCheck + + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/HsForeign.hs b/src/HsForeign.hs new file mode 100644 --- /dev/null +++ b/src/HsForeign.hs @@ -0,0 +1,7 @@ +module HsForeign + ( module HsForeign.Primitive + , module HsForeign.AsyncFFI + ) where + +import HsForeign.AsyncFFI +import HsForeign.Primitive diff --git a/src/HsForeign/AsyncFFI.hs b/src/HsForeign/AsyncFFI.hs new file mode 100644 --- /dev/null +++ b/src/HsForeign/AsyncFFI.hs @@ -0,0 +1,61 @@ +module HsForeign.AsyncFFI + ( withAsyncFFI + , withAsyncFFI' + , withPrimAsyncFFI + ) where + +import Control.Concurrent.MVar (newEmptyMVar, takeMVar) +import Control.Exception (mask_, onException) +import Control.Monad (void) +import Foreign.ForeignPtr +import Foreign.StablePtr +import GHC.Conc + +import HsForeign.Primitive + +withAsyncFFI + :: Int + -- ^ Size of callback data + -> (Ptr a -> IO a) + -- ^ Peek callback data + -> (StablePtr PrimMVar -> Int -> Ptr a -> IO b) + -- ^ Normal async foreign function: sp -> cap -> ptr -> () + -> IO a +withAsyncFFI = withAsyncFFI' [] + +withPrimAsyncFFI + :: Prim a + => (StablePtr PrimMVar -> Int -> Ptr a -> IO b) + -> IO a +withPrimAsyncFFI f = mask_ $ do + (ret, _) <- allocPrim $ \ret' -> do + mvar <- newEmptyMVar + sp <- newStablePtrPrimMVar mvar + (cap, _) <- threadCapability =<< myThreadId + void $ f sp cap ret' + takeMVar mvar `onException` forkIO (do takeMVar mvar;) + pure ret +{-# INLINABLE withPrimAsyncFFI #-} + +-- NOTE: memory allocated by haskell and pass to async cpp function must be +-- pinned. +withAsyncFFI' + :: [MutableByteArray RealWorld] + -- ^ A list of extra Bytes we will touch, usually it's empty + -> Int + -- ^ Size of callback data + -> (Ptr a -> IO a) + -- ^ Peek callback data + -> (StablePtr PrimMVar -> Int -> Ptr a -> IO b) + -- ^ Normal async foreign function: sp -> cap -> ptr -> () + -> IO a +withAsyncFFI' bas size peek_fun f = mask_ $ do + mvar <- newEmptyMVar + sp <- newStablePtrPrimMVar mvar + fp <- mallocForeignPtrBytes size + withForeignPtr fp $ \data' -> do + (cap, _) <- threadCapability =<< myThreadId + void $ f sp cap data' + takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp; touch bas) + peek_fun data' +{-# INLINABLE withAsyncFFI' #-} diff --git a/src/HsForeign/Primitive.hs b/src/HsForeign/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/HsForeign/Primitive.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module HsForeign.Primitive + ( BA# (BA#) + , MBA# (MBA#) + , BAArray# (BAArray#) + , withPrim, allocPrim + , withPrimUnsafe + , allocPrimUnsafe + , withPrimArray + , 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 . +withPrim :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b) +withPrim v f = do + buf <- newAlignedPinnedPrimArray 1 + writePrimArray buf 0 v + !b <- withMutablePrimArrayContents buf $ \ ptr -> f ptr + !a <- readPrimArray buf 0 + return (a, 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 f = do + buf <- newAlignedPinnedPrimArray 1 + !b <- withMutablePrimArrayContents buf $ \ ptr -> f ptr + !a <- readPrimArray buf 0 + return (a, 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 v f = do + -- All heap objects are WORD aligned so no need to do extra alignment + mpa@(MutablePrimArray mba#) <- newPrimArray 1 + writePrimArray mpa 0 v + !b <- f (MBA# mba#) + !a <- readPrimArray mpa 0 + return (a, 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 f = do + -- All heap objects are WORD aligned so no need to do extra alignment + mpa@(MutablePrimArray mba#) <- newPrimArray 1 + !b <- f (MBA# mba#) + !a <- readPrimArray mpa 0 + return (a, 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 . +withPrimArray :: (Prim a) => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b +withPrimArray arr f + | isPrimArrayPinned arr = do + let siz = sizeofPrimArray arr + withPrimArrayContents arr $ \ptr -> f ptr siz + | otherwise = do + let siz = sizeofPrimArray arr + buf <- newPinnedPrimArray siz + copyPrimArray buf 0 arr 0 siz + withMutablePrimArrayContents buf $ \ptr -> f ptr siz +{-# INLINABLE withPrimArray #-} + +-- 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 len f = do + mpa <- newAlignedPinnedPrimArray len + !r <- withMutablePrimArrayContents mpa f + !pa <- unsafeFreezePrimArray mpa + return (pa, 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 pa@(PrimArray ba#) f = f (BA# ba#) (sizeofPrimArray 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 len f = do + (mpa@(MutablePrimArray mba#) :: MutablePrimArray RealWorld a) <- newPrimArray len + !r <- f (MBA# mba#) + !pa <- unsafeFreezePrimArray mpa + return (pa, 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 . +withPrimArrayList + :: Prim a => [PrimArray a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b +withPrimArrayList pas0 f = do + let l = length pas0 + ptrs <- newPinnedPrimArray l + go ptrs 0 pas0 + where + go ptrs !_ [] = do pa <- unsafeFreezePrimArray ptrs + withPrimArray pa f + go ptrs !i (pa:pas) = + -- It's important to nest 'withPrimArray' calls to keep all pointers alive + withPrimArray pa $ \ ppa _ -> do + writePrimArray ptrs i ppa + go ptrs (i+1) pas + +withForeignPtrList :: [ForeignPtr a] -> (Ptr (Ptr a) -> Int -> IO b) -> IO b +withForeignPtrList fptrs f = do + let l = length fptrs + ptrs <- newPinnedPrimArray l + go ptrs 0 fptrs + where + go ptrs !_ [] = do + pa <- unsafeFreezePrimArray ptrs + withPrimArray pa f + go ptrs !i (fp:fps) = do + withForeignPtr fp $ \p -> do + writePrimArray ptrs i p + go ptrs (i+1) 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 pas f = do + let l = length pas + mla <- unsafeNewUnliftedArray l + foldM_ (\ !i pa -> writeUnliftedArray mla i pa >> return (i + 1)) 0 pas + (UnliftedArray la#) <- unsafeFreezeUnliftedArray mla + f (BAArray# (unsafeCoerce# la#)) l +{-# INLINE withPrimArrayListUnsafe #-} + +------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 902 +-- ghc<9.2 does not has a 'mutableByteArrayContents#' +mutableByteArrayContents# :: MutableByteArray# s -> Addr# +mutableByteArrayContents# mba# = byteArrayContents# (unsafeCoerce# 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 . +withMutablePrimArrayContents + :: MutablePrimArray RealWorld a + -> (Ptr a -> IO b) + -> IO b +withMutablePrimArrayContents (MutablePrimArray mba#) f = do + let addr# = mutableByteArrayContents# mba# + ptr = Ptr addr# + b <- f ptr + primitive_ (touch# mba#) + return 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 . +withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b +withPrimArrayContents (PrimArray ba#) f = do + let addr# = byteArrayContents# ba# + ptr = Ptr addr# + b <- f ptr + primitive_ (touch# ba#) + return b +{-# INLINE withPrimArrayContents #-} diff --git a/test/HsForeign/AsyncFFISpec.hs b/test/HsForeign/AsyncFFISpec.hs new file mode 100644 --- /dev/null +++ b/test/HsForeign/AsyncFFISpec.hs @@ -0,0 +1,23 @@ +module HsForeign.AsyncFFISpec (spec) where + +import Foreign.StablePtr +import GHC.Conc +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import HsForeign.AsyncFFI +import HsForeign.Primitive + +spec :: Spec +spec = describe "pass prim array list to async foreign function" $ do + prop "sum first should be equal" $ \xss -> + let pas = map (primArrayFromList . getNonEmpty) xss :: [PrimArray Int] + s = sum (map (head . getNonEmpty) xss) + f = withPrimArrayList pas $ \baa l -> withPrimAsyncFFI (async_sum_first baa l) + in unsafeDupablePerformIO f === s + +foreign import ccall unsafe async_sum_first + :: Ptr (Ptr Int) -> Int + -> StablePtr PrimMVar -> Int -> Ptr Int -> IO () diff --git a/test/HsForeign/PrimitiveSpec.hs b/test/HsForeign/PrimitiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HsForeign/PrimitiveSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MagicHash #-} + +module HsForeign.PrimitiveSpec (spec) where + +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import HsForeign.Primitive + +spec :: Spec +spec = describe "pass prim array list to foreign" $ do + prop "sum first should be equal(unsafe FFI)" $ \xss -> + let pas = map (primArrayFromList . getNonEmpty) xss :: [PrimArray Int] + s = sum (map (head . getNonEmpty) xss) + in unsafeDupablePerformIO (withPrimArrayListUnsafe pas sum_first_unsafe) === s + + prop "sum first should be equal(safe FFI)" $ \xss -> + let pas = map (primArrayFromList . getNonEmpty) xss :: [PrimArray Int] + s = sum (map (head . getNonEmpty) xss) + in unsafeDupablePerformIO (withPrimArrayList 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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} 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,52 @@ +#include +#include + +#include + +HsInt sum_first_unsafe(StgArrBytes** bufs, HsInt len) { + 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; +} + +typedef struct sum_first_callback_args { + HsInt** bufs; + HsInt len; + HsStablePtr mvar; + HsInt cap; + HsInt* value_out; +} sum_first_callback_args; + +void* sum_first_callback(void* args_) { + sum_first_callback_args* args = (sum_first_callback_args*)args_; + + HsInt res = 0; + for (HsInt ix = 0; ix < args->len; ix++) { + res = res + args->bufs[ix][0]; + } + *(args->value_out) = res; + hs_try_putmvar(args->cap, args->mvar); +} + +void async_sum_first(HsInt** bufs, HsInt len, HsStablePtr mvar, HsInt cap, + HsInt* value_out) { + sum_first_callback_args* args = malloc(sizeof(sum_first_callback_args)); + args->bufs = bufs; + args->len = len; + args->mvar = mvar; + args->cap = cap; + args->value_out = value_out; + + pthread_t p; + pthread_create(&p, NULL, sum_first_callback, (void*)args); +}