diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for cfuture + +## 1.0 -- 2025-04-21 + +* First version, with a foreign library and a test suite already. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,10 @@ +Copyright (c) 2025, Viktor Csimma +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * 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. + * Neither the name of the copyright holder nor the names of the 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 OWNER 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/cfuture.cabal b/cfuture.cabal new file mode 100644 --- /dev/null +++ b/cfuture.cabal @@ -0,0 +1,65 @@ +cabal-version: 3.0 +name: cfuture +version: 1.0 +synopsis: A Future type that is easy to represent and handle in C/C++. +description: + A module similar to the "future" package of Chris Kuklewicz, + but having a Future that is easy to represent and handle + in C/C++, + using two MVars. + Moreover, it uses two new threads: + one (the "watcher thread") aborts the calculation + if triggered by filling the first MVar. + +license: BSD-3-Clause +license-file: LICENSE +author: Viktor Csimma +maintainer: csimmaviktor03@gmail.com +category: Concurrency +build-type: Simple +extra-doc-files: CHANGELOG.md +common warnings + ghc-options: -Wall +source-repository head + type: git + location: git://github.com/viktorcsimma/cfuture.git + +library + import: warnings + exposed-modules: Control.Concurrent.CFuture + build-depends: base >=4.17.2 && < 5, + base-prelude >= 1.4 && < 1.7 + default-language: Haskell2010 + hs-source-dirs: src + c-sources: csrc/CFuture.c + include-dirs: include + install-includes: CFuture.h + + +foreign-library cfuture + type: native-shared + + other-modules: Control.Concurrent.CFuture + build-depends: base >=4.17.2 && < 5, + base-prelude >= 1.4 && < 1.7, + cfuture >= 1.0 && < 1.1 + + hs-source-dirs: src + c-sources: csrc/CFuture.c + include-dirs: include + install-includes: CFuture.h + + default-language: Haskell2010 + include-dirs: include + install-includes: CFuture.h + + +test-suite cfuture-test + import: warnings + default-language: Haskell2010 + other-modules: OurTasks, HsTestCase + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: main.c + build-depends: base, base-prelude, cfuture + diff --git a/csrc/CFuture.c b/csrc/CFuture.c new file mode 100644 --- /dev/null +++ b/csrc/CFuture.c @@ -0,0 +1,19 @@ +#include +#include + +/** + * Aborts the calculation + * and also frees the pointers in the Future. + */ +void abortC(CFuture future) { + hs_try_putmvar(-1, future[0]); + hs_free_stable_ptr(future[1]); +} + +/** + * Frees the pointers in the Future. + */ +void freeC(CFuture future) { + hs_free_stable_ptr(future[0]); + hs_free_stable_ptr(future[1]); +} diff --git a/include/CFuture.h b/include/CFuture.h new file mode 100644 --- /dev/null +++ b/include/CFuture.h @@ -0,0 +1,68 @@ +#include +#if defined(__cplusplus) +extern "C" { +#endif + +/** + * Represents a Haskell Future in C: + * one StablePtr points to the interruption MVar + * and the other one to the result MVar. + */ +typedef HsStablePtr CFuture[2]; + +/** + * Aborts the calculation + * and also frees the pointers in the Future. + */ +extern void abortC(CFuture future); + +/** + * Frees the pointers in the Future. + */ +extern void freeC(CFuture future); + +/** + * Waits for the calculation behind the Future + * and writes the result to the memory location + * defined by the pointer. + * If there is an exception instead of a result, + * it leaves the memory unchanged + * and returns 0; + * on success, it returns 1. + * + * For waiting for calculations without a result, + * see `waitC`. + */ +extern HsBool getC_Char(CFuture future, char* destination); +extern HsBool getC_Int(CFuture future, int* destination); +extern HsBool getC_Int8(CFuture future, int8_t* destination); +extern HsBool getC_Int16(CFuture future, int16_t* destination); +extern HsBool getC_Int32(CFuture future, int32_t* destination); +extern HsBool getC_Int64(CFuture future, int64_t* destination); +extern HsBool getC_Word(CFuture future, uint32_t* destination); +extern HsBool getC_Word8(CFuture future, uint8_t* destination); +extern HsBool getC_Word16(CFuture future, uint16_t* destination); +extern HsBool getC_Word32(CFuture future, uint32_t* destination); +extern HsBool getC_Word64(CFuture future, uint64_t* destination); +extern HsBool getC_Float(CFuture future, float* destination); +extern HsBool getC_Double(CFuture future, double* destination); +extern HsBool getC_Bool(CFuture future, int* destination); +extern HsBool getC_Ptr(CFuture future, void** destination); +extern HsBool getC_FunPtr(CFuture future, void (*destination)(void)); +extern HsBool getC_StablePtr(CFuture future, HsStablePtr* destination); + +/** + * Waits for the calculation behind the Future. + * If there is an exception instead of a result, + * it returns 0; + * on success, it returns 1. + * + * For also retrieving results from non-void Futures, + * see `getC`. + */ +extern HsBool waitC(CFuture future); + +#if defined(__cplusplus) +} +#endif + diff --git a/src/Control/Concurrent/CFuture.hs b/src/Control/Concurrent/CFuture.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/CFuture.hs @@ -0,0 +1,180 @@ +-- | A Future type that is easy to represent and handle +-- in C\/C++, +-- using two 'MVar's. +-- Moreover, it uses two new threads: +-- one (the "watcher thread") aborts the calculation +-- if triggered by filling the first 'MVar'. +module Control.Concurrent.CFuture + (Future, FutureResult, CFuturePtr, + forkFuture, writeFutureC, forkFutureC, + safeGet, get, getC, waitC, abort) + where + +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable +import Control.Concurrent +import Control.Exception(throw, toException, SomeException) +import BasePrelude (PrimMVar, newStablePtrPrimMVar, + Int8, Int16, Int32, Int64, + Word8, Word16, Word32, Word64) + +-- | An exception is thrown +-- if the Future has been aborted. +type FutureResult a = Either SomeException a + +-- | A C pointer to a C array of two 'StablePtr's. +type CFuturePtr = Ptr (StablePtr PrimMVar) + +-- | A type similar to C++ futures, +-- that can be passed to C and used +-- to interrupt asynchronous calls +-- or to get their results. +-- +-- From within Haskell, you can use +-- 'forkFuture' to start a calculation, +-- 'safeGet' or 'get' to wait on it +-- and 'abort' to abort it. +-- +-- From C, interruption happens +-- via calling hs_try_putmvar +-- on the first 'StablePtr'; +-- freeing the pointers is possible +-- via hs_free_stable_ptr -- +-- all these without the cost of an FFI call. + +data Future a = MkFuture + (MVar ()) -- interruption: fill it to interrupt the calculation + (MVar (FutureResult a)) -- result: where the result or the exception will be put + +-- | Starts an asynchronous calculation +-- and returns a 'Future' to it. +forkFuture :: IO a -> IO (Future a) +forkFuture action = do + intMVar <- (newEmptyMVar :: IO (MVar ())) + resMVar <- (newEmptyMVar :: IO (MVar (FutureResult a))) + + -- The thread doing the actual calculation. + -- It also wakes up the watcher thread. + calculationThreadId <- forkIO $ (putMVar resMVar =<< (Right <$> action)) >> putMVar intMVar () + + -- The thread killing the calculation thread if woken up. + _ <- forkIO $ do + -- this is activated if intMVar gets filled + readMVar intMVar + killThread calculationThreadId + putMVar resMVar (Left (toException (userError "Calculation aborted"))) + + return $ MkFuture intMVar resMVar + +-- | Interrupts the calculation behind the 'Future'. +-- Do not call this from C; +-- use hs_try_putmvar instead +-- (that frees the first 'MVar', too). +-- Returns 'False' if it has already been interrupted +-- and 'True' otherwise. +abort :: Future a -> IO Bool +abort (MkFuture intMVar _) = tryPutMVar intMVar () + +-- | Creates 'StablePtr's +-- and writes them to a memory area +-- provided by a C caller. +-- Use this in functions where the C frontend provides +-- a 'CFuturePtr' to write the future to. +-- +-- Note: it is the responsibility of the C side +-- to free the 'StablePtr's. +writeFutureC :: CFuturePtr -> Future a -> IO () +writeFutureC ptr (MkFuture intMVar resMVar) = do + intMVarSPtr <- newStablePtrPrimMVar intMVar + resMVarSPtr <- newStablePtr resMVar + let convPtr = (castPtr ptr :: CFuturePtr) + poke convPtr intMVarSPtr + pokeElemOff (castPtr convPtr) 1 resMVarSPtr + +-- | Similar to 'forkFuture', but +-- we write the 'Future' into a location +-- given by the caller. +-- This makes it easier to create C exports +-- for actions. +-- +-- Use this in functions where the C frontend provides +-- a 'CFuturePtr' to write the future to. +-- +-- Note: it is the responsibility of the C side +-- to free the 'StablePtr's. +forkFutureC :: IO a -> CFuturePtr -> IO () +forkFutureC action ptr = writeFutureC ptr =<< forkFuture action + +-- | Reads the result from the 'Future' +-- but does not check whether there has been an exception +-- wrapped into a 'Left'. +-- This is a blocking call, +-- waiting for the result until it is ready. +safeGet :: Future a -> IO (FutureResult a) +safeGet (MkFuture _ resMVar) = readMVar resMVar + +-- | Similar to 'safeGet', but checks whether we have an exception +-- and rethrows it if yes; +-- returning the plain result otherwise. +-- This is a blocking call, +-- waiting for the result until it is ready. +get :: Future a -> IO a +get future = safeGet future >>= either throw return + +-- | A variant of 'get' to call from C +-- which writes the result to the memory location +-- defined by the pointer. +-- If there is an exception instead of a result, +-- it writes nothing to the pointer +-- and returns 'False'; +-- on success, it returns 'True'. +getC :: Storable a => CFuturePtr -> Ptr a -> IO Bool +getC futurePtr destPtr = do + -- we assume both StablePtrs are of the same size + resMVarSPtr <- peekElemOff (castPtr futurePtr :: Ptr (StablePtr (MVar (FutureResult a)))) 1 + -- we catch the exception + -- as C/C++ could not handle it + result <- readMVar =<< deRefStablePtr resMVarSPtr + case result of + Right a -> poke destPtr a >> return True + _ -> return False + +-- | Only waits until the calculation gets finished; +-- then returns 'True' if it was successful and 'False' otherwise. +-- To be called from C. +waitC :: CFuturePtr -> IO Bool +waitC ptr = do + -- we assume both StablePtrs are of the same size + resMVarSPtr <- peekElemOff (castPtr ptr :: Ptr (StablePtr (MVar (Either String ())))) 1 + -- we catch the exception and return an illegal value + -- in order to unblock a C++ thread waiting for the result + result <- readMVar =<< deRefStablePtr resMVarSPtr + case result of + Right _ -> return True + _ -> return False + +-- Finally, the foreign export declarations: +-- this is quite ugly, but c'est la vie. +-- It does not work with a void pointer +-- because then, the Haskell side does not get to know the type +-- and tries to poke a (). +foreign export ccall "getC_Char" getC :: CFuturePtr -> Ptr Char -> IO Bool +foreign export ccall "getC_Int" getC :: CFuturePtr -> Ptr Int -> IO Bool +foreign export ccall "getC_Int8" getC :: CFuturePtr -> Ptr Int8 -> IO Bool +foreign export ccall "getC_Int16" getC :: CFuturePtr -> Ptr Int16 -> IO Bool +foreign export ccall "getC_Int32" getC :: CFuturePtr -> Ptr Int32 -> IO Bool +foreign export ccall "getC_Int64" getC :: CFuturePtr -> Ptr Int64 -> IO Bool +foreign export ccall "getC_Word" getC :: CFuturePtr -> Ptr Word -> IO Bool +foreign export ccall "getC_Word8" getC :: CFuturePtr -> Ptr Word8 -> IO Bool +foreign export ccall "getC_Word16" getC :: CFuturePtr -> Ptr Word16 -> IO Bool +foreign export ccall "getC_Word32" getC :: CFuturePtr -> Ptr Word32 -> IO Bool +foreign export ccall "getC_Word64" getC :: CFuturePtr -> Ptr Word64 -> IO Bool +foreign export ccall "getC_Float" getC :: CFuturePtr -> Ptr Float -> IO Bool +foreign export ccall "getC_Double" getC :: CFuturePtr -> Ptr Double -> IO Bool +foreign export ccall "getC_Bool" getC :: CFuturePtr -> Ptr Bool -> IO Bool +foreign export ccall "getC_Ptr" getC :: CFuturePtr -> Ptr (Ptr a) -> IO Bool +foreign export ccall "getC_FunPtr" getC :: CFuturePtr -> Ptr (FunPtr a) -> IO Bool +foreign export ccall "getC_StablePtr" getC :: CFuturePtr -> Ptr (StablePtr a) -> IO Bool +foreign export ccall waitC :: CFuturePtr -> IO Bool + diff --git a/test/HsTestCase.hs b/test/HsTestCase.hs new file mode 100644 --- /dev/null +++ b/test/HsTestCase.hs @@ -0,0 +1,23 @@ +-- We call this from main.c. +module HsTestCase (hsTestCase) where + +import Control.Concurrent.CFuture +import Control.Concurrent (threadDelay) +import OurTasks + +hsTestCase :: IO Bool +hsTestCase = do + print "Working" + future <- forkFuture task + print "Delay" + threadDelay 2000000 + _ <- abort future + print "Aborted" + result <- safeGet future + -- it should be an exception + case result of + Left _ -> return True + _ -> return False + +foreign export ccall hsTestCase :: IO Bool + diff --git a/test/OurTasks.hs b/test/OurTasks.hs new file mode 100644 --- /dev/null +++ b/test/OurTasks.hs @@ -0,0 +1,16 @@ +module OurTasks where +import Control.Concurrent.CFuture +import Control.Concurrent (threadDelay) + +task :: IO Int +task = sum <$> mapM subtask [1..10] + where + subtask :: Int -> IO Int + subtask n = do + print n + threadDelay 1000000 + return $ 2 * n + +cFunction :: CFuturePtr -> IO () +cFunction = forkFutureC task +foreign export ccall cFunction :: CFuturePtr -> IO () diff --git a/test/main.c b/test/main.c new file mode 100644 --- /dev/null +++ b/test/main.c @@ -0,0 +1,49 @@ +#include + +#include +#include "OurTasks_stub.h" +#include "CFuture.h" + +/** + * See HsTestCase.h. + */ +int hsTestCase(void); + +/** + * A non-zero return value means a fail. + */ +int main(int argc, char* argv[]) { + hs_init(&argc, &argv); + + /* Test 1: a successful run */ + + CFuture future; + cFunction(future); + + int result; + int success = getC_Int(future, &result); + freeC(future); + + printf(success ? "Successful background calculation\n" : "Failed background calculation\n"); + printf("Result of cFunction: %d\n", result); + + int firstTestPassed = success && 110 == result; + + /* Test 2: an aborted run */ + + cFunction(future); + /* cannot use sleep() as that also halts the Haskell thread */ + abortC(future); /* this also frees it */ + + printf(success ? "Aborted successfully\n" : "Failed while aborting\n"); + + int secondTestPassed = !success; + + /* Test 3: an aborted run in Haskell */ + int thirdTestPassed = hsTestCase(); + + /* Finally: */ + + hs_exit(); + return (!firstTestPassed && !secondTestPassed && thirdTestPassed); /* 0 if all tests passed */ +}