diff --git a/cxx-src/HaskellException.cxx b/cxx-src/HaskellException.cxx --- a/cxx-src/HaskellException.cxx +++ b/cxx-src/HaskellException.cxx @@ -1,6 +1,21 @@ - #include "HaskellException.hxx" +// see +// +// regarding how to detect g++ or clang. +// +// the defined(__clang__) should actually be redundant, since apparently it also +// defines GNUC, but but let's be safe. + +#include +#include + +#if defined(__GNUC__) || defined(__clang__) +#include +#include +#endif + + HaskellException::HaskellException(std::string renderedExceptionIn, void *haskellExceptionStablePtrIn) : haskellExceptionStablePtr(new HaskellStablePtr(haskellExceptionStablePtrIn)) , displayExceptionValue(renderedExceptionIn) @@ -15,4 +30,40 @@ const char* HaskellException::what() const noexcept { return displayExceptionValue.c_str(); +} + + +// see +// +// regarding how to show the type of an exception. + +#if defined(__GNUC__) || defined(__clang__) +const char* currentExceptionTypeName() +{ + int demangle_status; + return abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status); +} +#endif + +void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__){ +#if defined(__GNUC__) || defined(__clang__) + const char* demangle_result = currentExceptionTypeName(); + std::string message = "Exception: " + std::string(e.what()) + "; type: " + std::string(demangle_result); +#else + std::string message = "Exception: " + std::string(e.what()) + "; type: not available (please use g++ or clang)"; +#endif + size_t message_len = message.size() + 1; + *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len)); + std::memcpy(*__inline_c_cpp_error_message__, message.c_str(), message_len); +} + +void setMessageOfOtherException(char** __inline_c_cpp_error_message__){ +#if defined(__GNUC__) || defined(__clang__) + const char* message = currentExceptionTypeName(); + size_t message_len = strlen(message) + 1; + *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len)); + std::memcpy(*__inline_c_cpp_error_message__, message, message_len); +#else + *__inline_c_cpp_error_message__ = NULL; +#endif } diff --git a/cxx-src/HaskellStablePtr.cxx b/cxx-src/HaskellStablePtr.cxx --- a/cxx-src/HaskellStablePtr.cxx +++ b/cxx-src/HaskellStablePtr.cxx @@ -1,6 +1,5 @@ #include "HaskellStablePtr.hxx" -#include "HsFFI.h" HaskellStablePtr::~HaskellStablePtr() { if (stablePtr != STABLE_PTR_NULL) { diff --git a/include/HaskellException.hxx b/include/HaskellException.hxx --- a/include/HaskellException.hxx +++ b/include/HaskellException.hxx @@ -4,6 +4,7 @@ #include "HaskellStablePtr.hxx" #include #include +#include /* A representation of a Haskell exception (SomeException), with a precomputed exception message from Control.Exception.displayException. @@ -25,3 +26,6 @@ virtual const char* what() const noexcept override; }; + +void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__); +void setMessageOfOtherException(char** __inline_c_cpp_error_message__); diff --git a/inline-c-cpp.cabal b/inline-c-cpp.cabal --- a/inline-c-cpp.cabal +++ b/inline-c-cpp.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: inline-c-cpp -version: 0.4.0.2 +version: 0.4.0.3 synopsis: Lets you embed C++ code into Haskell. description: Utilities to inline C++ code into Haskell using inline-c. See tests for example on how to build. @@ -9,16 +10,55 @@ maintainer: f@mazzo.li copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 Francesco Mazzoli category: FFI -tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 +tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.2 build-type: Simple -cabal-version: >=1.10 extra-source-files: test/*.h source-repository head type: git location: https://github.com/fpco/inline-c +flag std-vector-example + description: Build std::vector example + default: False + +common cxx-opts + -- These options are for compilation of C++ _files_. We need to duplicate + -- these in ghc-options to apply them on inline-c-cpp snippets. + -- This is partly(?) due to Cabal < 3.2.1.0 not passing cxx-options to + -- GHC 8.10 correctly. See https://github.com/haskell/cabal/issues/6421 + cxx-options: + -- Compilers strive to be ABI compatible regardless of the C++ language + -- version (except perhaps experimental features). + -- Discussion: https://stackoverflow.com/questions/46746878/is-it-safe-to-link-c17-c14-and-c11-objects/49118876 + -- We only have to raise this if a new inline-c-cpp feature requires us to + -- bundle C++ code that requires a newer version of the standard. + -- Generated code in user libraries will be compiled with the language + -- version configured there. + -std=c++11 + -Wall + extra-libraries: stdc++ + + if os(darwin) + -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829 + ld-options: -Wl,-keep_dwarf_unwind + + if impl(ghc >= 8.10) + ghc-options: + -optcxx-std=c++11 + -optcxx-Wall + else + -- On GHC < 8.10, we have to emulate -optcxx by making the C compiler compile + -- C++. GCC accepts this via -std, whereas Clang requires us to change the + -- command. + ghc-options: + -optc-std=c++11 + -optc-Wall + if os(darwin) + ghc-options: -pgmc=clang++ + library + import: cxx-opts exposed-modules: Language.C.Inline.Cpp Language.C.Inline.Cpp.Exceptions build-depends: base >=4.7 && <5 @@ -28,33 +68,34 @@ , containers hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -optc-xc++ -optc-std=c++11 + ghc-options: -Wall include-dirs: include install-includes: HaskellException.hxx HaskellStablePtr.hxx - extra-libraries: stdc++ - c-sources: cxx-src/HaskellException.cxx cxx-src/HaskellStablePtr.cxx - cc-options: -Wall -std=c++11 - if os(darwin) - -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829 - ld-options: -Wl,-keep_dwarf_unwind - ghc-options: -pgmc=clang++ + cxx-sources: cxx-src/HaskellException.cxx + cxx-src/HaskellStablePtr.cxx test-suite tests + import: cxx-opts type: exitcode-stdio-1.0 hs-source-dirs: test main-is: tests.hs + other-modules: StdVector build-depends: base >=4 && <5 , inline-c , inline-c-cpp , safe-exceptions , hspec , containers + , template-haskell + , vector default-language: Haskell2010 - ghc-options: - -optc-std=c++11 - if os(darwin) - ghc-options: -pgmc=clang++ - extra-libraries: stdc++ - cc-options: -Wall -Werror -optc-xc++ -std=c++11 - if os(darwin) - ld-options: -Wl,-keep_dwarf_unwind + cxx-options: -Werror + + if impl(ghc >= 8.10) + ghc-options: + -optcxx-Werror + -- else + -- ghc-options: + -- -- GHC < 8.10 can pass options to the C++ compiler, but it warns + -- -- so -Werror will not work. + -- -optc-Werror diff --git a/src/Language/C/Inline/Cpp/Exceptions.hs b/src/Language/C/Inline/Cpp/Exceptions.hs --- a/src/Language/C/Inline/Cpp/Exceptions.hs +++ b/src/Language/C/Inline/Cpp/Exceptions.hs @@ -161,28 +161,10 @@ tryBlockQuoteExp :: String -> Q Exp tryBlockQuoteExp blockStr = do let (ty, body) = C.splitTypedC blockStr - _ <- C.include "" - _ <- C.include "" - _ <- C.include "" _ <- C.include "HaskellException.hxx" - -- see - -- - -- regarding how to detect g++ or clang. - -- - -- the defined(__clang__) should actually be redundant, since apparently it also - -- defines GNUC, but but let's be safe. - _ <- C.verbatim $ unlines - [ "#if defined(__GNUC__) || defined(__clang__)" - , "#include " - , "#include " - , "#endif" - ] typePtrVarName <- newName "exTypePtr" msgPtrVarName <- newName "msgPtr" haskellExPtrVarName <- newName "haskellExPtr" - -- see - -- - -- regarding how to show the type of an exception. let inlineCStr = unlines [ ty ++ " {" , " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");" @@ -193,31 +175,14 @@ , " } catch (HaskellException &e) {" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" - , if ty == "void" then "return;" else "return {};" + , " return " ++ exceptionalValue ty ++ ";" , " } catch (std::exception &e) {" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" - , "#if defined(__GNUC__) || defined(__clang__)" - , " int demangle_status;" - , " const char* demangle_result = abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status);" - , " std::string message = \"Exception: \" + std::string(e.what()) + \"; type: \" + std::string(demangle_result);" - , "#else" - , " std::string message = \"Exception: \" + std::string(e.what()) + \"; type: not available (please use g++ or clang)\";" - , "#endif" - , " size_t message_len = message.size() + 1;" - , " *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len));" - , " std::memcpy(*__inline_c_cpp_error_message__, message.c_str(), message_len);" + , " setMessageOfStdException(e,__inline_c_cpp_error_message__);" , " return " ++ exceptionalValue ty ++ ";" , " } catch (...) {" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" - , "#if defined(__GNUC__) || defined(__clang__)" - , " int demangle_status;" - , " const char* message = abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status);" - , " size_t message_len = strlen(message) + 1;" - , " *__inline_c_cpp_error_message__ = static_cast(std::malloc(message_len));" - , " std::memcpy(*__inline_c_cpp_error_message__, message, message_len);" - , "#else" - , " *__inline_c_cpp_error_message__ = NULL;" - , "#endif" + , " setMessageOfOtherException(__inline_c_cpp_error_message__);" , " return " ++ exceptionalValue ty ++ ";" , " }" , "}" diff --git a/test/StdVector.hs b/test/StdVector.hs new file mode 100644 --- /dev/null +++ b/test/StdVector.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +module StdVector + ( stdVectorCtx + , instanceStdVector + , CStdVector + , StdVector() + , StdVector.new + , size + , toVector + , pushBack + ) + +where + +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Unsafe as CU +import qualified Language.C.Inline.Context as C +import qualified Language.C.Inline.Cpp as C +import qualified Language.C.Types as C +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Data.Map.Strict as M +import Control.Monad +import Data.Maybe +import Language.Haskell.TH.Syntax +import Foreign +import Foreign.C +import Language.Haskell.TH +import Data.Proxy +import Control.Exception (mask_) + +data CStdVector a + +stdVectorCtx :: C.Context +stdVectorCtx = C.cppCtx `mappend` C.cppTypePairs [ ("std::vector", [t| CStdVector |]) ] + +newtype StdVector a = StdVector (ForeignPtr (CStdVector a)) + +class HasStdVector a where + cNew :: IO (Ptr (CStdVector a)) + cDelete :: FunPtr (Ptr (CStdVector a) -> IO ()) + cSize :: Ptr (CStdVector a) -> IO CSize + cCopyTo :: Ptr (CStdVector a) -> Ptr a -> IO () + cPushBack :: a -> Ptr (CStdVector a) -> IO () + +instanceStdVector :: String -> DecsQ +instanceStdVector cType = fmap concat $ sequence + [ C.include "" + , C.include "" + , C.substitute + [ ( "T", \_ -> cType ) + , ( "VEC", \var -> "$(std::vector<" ++ cType ++ ">* " ++ var ++ ")" ) + ] [d| + instance HasStdVector $(C.getHaskellType False cType) where + cNew = [CU.exp| std::vector<@T()>* { new std::vector<@T()>() } |] + cDelete = [C.funPtr| void deleteStdVector(std::vector<@T()>* vec) { delete vec; } |] + cSize vec = [CU.exp| size_t { @VEC(vec)->size() } |] + cCopyTo vec dstPtr = [CU.block| void { + const std::vector<@T()>* vec = @VEC(vec); + std::copy(vec->begin(), vec->end(), $(@T()* dstPtr)); + } |] + cPushBack value vec = [CU.exp| void { @VEC(vec)->push_back($(@T() value)) } |] + |] + ] + +new :: forall a. HasStdVector a => IO (StdVector a) +new = mask_ $ do + ptr <- cNew @a + StdVector <$> newForeignPtr cDelete ptr + +size :: HasStdVector a => StdVector a -> IO Int +size (StdVector fptr) = fromIntegral <$> withForeignPtr fptr cSize + +toVector :: (HasStdVector a, Storable a) => StdVector a -> IO (VS.Vector a) +toVector stdVec@(StdVector stdVecFPtr) = do + vecSize <- size stdVec + hsVec <- VSM.new vecSize + withForeignPtr stdVecFPtr $ \stdVecPtr -> + VSM.unsafeWith hsVec $ \hsVecPtr -> + cCopyTo stdVecPtr hsVecPtr + VS.unsafeFreeze hsVec + +pushBack :: HasStdVector a => StdVector a -> a -> IO () +pushBack (StdVector fptr) value = withForeignPtr fptr (cPushBack value) diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} import Control.Exception.Safe import Control.Monad @@ -26,19 +27,20 @@ import Foreign.C.String (withCString) import Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) import qualified Test.Hspec as Hspec +import Test.Hspec (shouldBe) import Foreign.Ptr (Ptr) import Data.List (isInfixOf) import Data.Monoid +import qualified StdVector +import qualified Data.Vector.Storable as VS data Test -data Vector a data Array a C.context $ C.cppCtx `mappend` C.cppTypePairs [ ("Test::Test", [t|Test|]), - ("std::vector", [t|Vector|]), ("std::array", [t|Array|]) - ] + ] `mappend` StdVector.stdVectorCtx C.include "" C.include "" @@ -51,6 +53,9 @@ deriving (Eq, Show, Typeable) instance Exception MyCustomException +StdVector.instanceStdVector "int" +StdVector.instanceStdVector "double" + main :: IO () main = Hspec.hspec $ do Hspec.describe "Basic C++" $ do @@ -72,7 +77,7 @@ Hspec.it "Hello Template" $ do pt <- [C.block| std::vector* { return new std::vector(); - } |] :: IO (Ptr (Vector C.CInt)) + } |] :: IO (Ptr (StdVector.CStdVector C.CInt)) [C.block| void { $(std::vector* pt)->push_back(100); std::cout << (*$(std::vector* pt))[0] << std::endl; @@ -81,7 +86,7 @@ Hspec.it "Template + Namespace" $ do pt <- [C.block| std::vector* { return new std::vector(); - } |] :: IO (Ptr (Vector Test)) + } |] :: IO (Ptr (StdVector.CStdVector Test)) [C.block| void { $(std::vector* pt)->push_back(Test::Test()); } |] @@ -239,6 +244,31 @@ |] result `shouldBeRight` 0xDEADBEEF + + Hspec.describe "Macros" $ do + Hspec.it "generated std::vector instances work correctly" $ do + intVec <- StdVector.new @C.CInt + StdVector.pushBack intVec 4 + StdVector.pushBack intVec 5 + hsIntVec <- StdVector.toVector intVec + VS.toList hsIntVec `shouldBe` [ 4, 5 ] + + doubleVec <- StdVector.new @C.CDouble + StdVector.pushBack doubleVec 4.3 + StdVector.pushBack doubleVec 6.7 + hsDoubleVec <- StdVector.toVector doubleVec + VS.toList hsDoubleVec `shouldBe` [ 4.3, 6.7 ] + + Hspec.it "Template with pointers" $ do + pt <- [C.block| std::vector* { + return new std::vector(); + } |] :: IO (Ptr (StdVector.CStdVector (Ptr C.CInt))) + [C.block| void { + int *a = new int; + *a = 100; + $(std::vector* pt)->push_back(a); + std::cout << *((*$(std::vector* pt))[0]) << std::endl; + } |] tag :: C.CppException -> String tag (C.CppStdException {}) = "CppStdException"