packages feed

foreign (empty) → 0.1.0.0

raw patch · 12 files changed

+565/−0 lines, 12 filesdep +QuickCheckdep +basedep +foreignsetup-changed

Dependencies added: QuickCheck, base, foreign, ghc-prim, hspec, primitive, primitive-unlifted

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for foreign++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,4 @@+# foreign++A collection of data types, classes, and functions for easing your ffi+experience.
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ foreign.cabal view
@@ -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 <https://github.com/4eUeP/foreign#readme>++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
+ src/HsForeign.hs view
@@ -0,0 +1,7 @@+module HsForeign+  ( module HsForeign.Primitive+  , module HsForeign.AsyncFFI+  ) where++import           HsForeign.AsyncFFI+import           HsForeign.Primitive
+ src/HsForeign/AsyncFFI.hs view
@@ -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' #-}
+ src/HsForeign/Primitive.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 #-}
+ test/HsForeign/AsyncFFISpec.hs view
@@ -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 ()
+ test/HsForeign/PrimitiveSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/cbits/ffi.c view
@@ -0,0 +1,52 @@+#include <HsFFI.h>+#include <Rts.h>++#include <pthread.h>++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);+}