diff --git a/cxx-src/HaskellException.cxx b/cxx-src/HaskellException.cxx --- a/cxx-src/HaskellException.cxx +++ b/cxx-src/HaskellException.cxx @@ -46,25 +46,51 @@ // // regarding how to show the type of an exception. +/* mallocs a string representing the exception type name or error condition. + + Ideally, this returns a demangled string, but it may degrade to + - a mangled string if demangling fails, + - "" if exception type info is not available, + - "" if no current exception is found. + + The responsibility for freeing the returned string falls on the caller, + such as handleForeignCatch, which passes the responsibility on to ByteString + + */ #if defined(__GNUC__) || defined(__clang__) const char* currentExceptionTypeName() { + std::type_info *type_info = abi::__cxa_current_exception_type(); + if (!type_info) + return strdup(""); + + const char *raw_name = type_info->name(); + if (!raw_name) + return strdup(""); + int demangle_status; - return abi::__cxa_demangle(abi::__cxa_current_exception_type()->name(), 0, 0, &demangle_status); + const char *demangled_name = abi::__cxa_demangle(raw_name, 0, 0, &demangle_status); + if (!demangled_name) + return strdup(raw_name); + + return demangled_name; } #endif -void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typStrPtr){ +/* Set the message and type strings. + + The responsibility for freeing the returned string falls on the caller, + such as handleForeignCatch, which passes the responsibility on to a + ByteString. + */ +void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typStrPtr){ *msgStrPtr = strdup(e.what()); setCppExceptionType(typStrPtr); } -void setCppExceptionType(char** typStrPtr){ +void setCppExceptionType(const char** typStrPtr){ #if defined(__GNUC__) || defined(__clang__) - const char* message = currentExceptionTypeName(); - size_t message_len = strlen(message) + 1; - *typStrPtr = static_cast(std::malloc(message_len)); - std::memcpy(*typStrPtr, message, message_len); + *typStrPtr = currentExceptionTypeName(); #else *typStrPtr = NULL; #endif diff --git a/include/HaskellException.hxx b/include/HaskellException.hxx --- a/include/HaskellException.hxx +++ b/include/HaskellException.hxx @@ -36,5 +36,5 @@ }; -void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typeStrPtr); -void setCppExceptionType(char** typeStrPtr); +void setMessageOfStdException(const std::exception &e, const char** msgStrPtr, const char **typeStrPtr); +void setCppExceptionType(const char** typeStrPtr); diff --git a/inline-c-cpp.cabal b/inline-c-cpp.cabal --- a/inline-c-cpp.cabal +++ b/inline-c-cpp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: inline-c-cpp -version: 0.5.0.0 +version: 0.5.0.1 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. @@ -37,9 +37,14 @@ -- version configured there. -std=c++11 -Wall - extra-libraries: stdc++ - if os(darwin) + -- Linking to the C++ standard library + if impl(ghc >= 9.4) + build-depends: system-cxx-std-lib == 1.0 + elif os(linux) + extra-libraries: stdc++ + elif os(darwin) + extra-libraries: c++ -- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829 ld-options: -Wl,-keep_dwarf_unwind @@ -62,6 +67,7 @@ exposed-modules: Language.C.Inline.Cpp Language.C.Inline.Cpp.Exception Language.C.Inline.Cpp.Exceptions + Language.C.Inline.Cpp.Unsafe build-depends: base >=4.7 && <5 , bytestring , inline-c >= 0.9.0.0 diff --git a/src/Language/C/Inline/Cpp/Exception.hs b/src/Language/C/Inline/Cpp/Exception.hs --- a/src/Language/C/Inline/Cpp/Exception.hs +++ b/src/Language/C/Inline/Cpp/Exception.hs @@ -12,6 +12,7 @@ , throwBlock , tryBlock , catchBlock + , tryBlockQuoteExp ) where import Control.Exception.Safe @@ -52,8 +53,15 @@ type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr +-- | This converts a plain pointer to a managed object. +-- +-- The pointer must have been created with @new@. The returned 'CppExceptionPtr' +-- will @delete@ it when it is garbage collected, so you must not @delete@ it +-- on your own. This function is called "unsafe" because it is not memory safe +-- by itself, but safe when used correctly; similar to for example +-- 'BS.unsafePackMallocCString'. unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr -unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p +unsafeFromNewCppExceptionPtr = newForeignPtr finalizeAbstractCppExceptionPtr finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr {-# NOINLINE finalizeAbstractCppExceptionPtr #-} @@ -83,27 +91,36 @@ pattern ExTypeOtherException = 3 -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) +handleForeignCatch :: (Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) handleForeignCatch cont = - alloca $ \exTypePtr -> - alloca $ \msgCStringPtr -> - alloca $ \typCStringPtr -> - alloca $ \exPtr -> - alloca $ \haskellExPtrPtr -> do - poke exTypePtr ExTypeNoException + allocaBytesAligned (sizeOf (undefined :: Ptr ()) * 5) (alignment (undefined :: Ptr ())) $ \basePtr -> do + let ptrSize = sizeOf (undefined :: Ptr ()) + exTypePtr = castPtr basePtr :: Ptr CInt + msgCStringPtr = castPtr (basePtr `plusPtr` ptrSize) :: Ptr CString + typCStringPtr = castPtr (basePtr `plusPtr` (ptrSize*2)) :: Ptr CString + exPtr = castPtr (basePtr `plusPtr` (ptrSize*3)) :: Ptr (Ptr AbstractCppExceptionPtr) + haskellExPtrPtr = castPtr (basePtr `plusPtr` (ptrSize*4)) :: Ptr (Ptr ()) -- we need to mask this entire block because the C++ allocates the -- string for the exception message and we need to make sure that -- we free it (see the @free@ below). The foreign code would not be -- preemptable anyway, so I do not think this loses us anything. mask_ $ do - res <- cont exTypePtr msgCStringPtr typCStringPtr exPtr haskellExPtrPtr + res <- cont basePtr exType <- peek exTypePtr case exType of ExTypeNoException -> return (Right res) ExTypeStdException -> do ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + + -- BS.unsafePackMallocCString: safe because setMessageOfStdException + -- (invoked via tryBlockQuoteExp) sets msgCStringPtr to a newly + -- malloced string. errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr + + -- BS.unsafePackMallocCString: safe because currentExceptionTypeName + -- returns a newly malloced string mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppStdException ex errMsg mbExcType)) ExTypeHaskellException -> do haskellExPtr <- peek haskellExPtrPtr @@ -117,7 +134,11 @@ return (Left (CppHaskellException someExc)) ExTypeOtherException -> do ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + + -- BS.unsafePackMallocCString: safe because currentExceptionTypeName + -- returns a newly malloced string mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) _ -> error "Unexpected C++ exception type." @@ -126,7 +147,7 @@ throwBlock :: QuasiQuoter throwBlock = QuasiQuoter { quoteExp = \blockStr -> do - [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |] + [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp C.block blockStr) |] , quotePat = unsupported , quoteType = unsupported , quoteDec = unsupported @@ -187,22 +208,20 @@ "jmp_buf" -> "0" _ -> "{}" -tryBlockQuoteExp :: String -> Q Exp -tryBlockQuoteExp blockStr = do +tryBlockQuoteExp :: QuasiQuoter -> String -> Q Exp +tryBlockQuoteExp block blockStr = do let (ty, body) = C.splitTypedC blockStr _ <- C.include "HaskellException.hxx" - typePtrVarName <- newName "exTypePtr" - msgPtrVarName <- newName "msgPtr" - haskellExPtrVarName <- newName "haskellExPtr" - exPtrVarName <- newName "exPtr" - typeStrPtrVarName <- newName "typeStrPtr" + basePtrVarName <- newName "basePtr" let inlineCStr = unlines [ ty ++ " {" - , " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");" - , " char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");" - , " char** __inline_c_cpp_error_typ__ = $(char** " ++ nameBase typeStrPtrVarName ++ ");" - , " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " ++ nameBase haskellExPtrVarName ++ "));" - , " std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)$(std::exception_ptr** " ++ nameBase exPtrVarName ++ ");" + , " void** __inline_c_cpp_base_ptr__ = $(void** " ++ nameBase basePtrVarName ++ ");" + , " int* __inline_c_cpp_exception_type__ = (int*)__inline_c_cpp_base_ptr__;" + , " const char** __inline_c_cpp_error_message__ = (const char**)(__inline_c_cpp_base_ptr__ + 1);" + , " const char** __inline_c_cpp_error_typ__ = (const char**)(__inline_c_cpp_base_ptr__ + 2);" + , " std::exception_ptr** __inline_c_cpp_exception_ptr__ = (std::exception_ptr**)(__inline_c_cpp_base_ptr__ + 3);" + , " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)(__inline_c_cpp_base_ptr__ + 4);" + , " *__inline_c_cpp_exception_type__ = 0;" , " try {" , body , " } catch (const HaskellException &e) {" @@ -222,13 +241,13 @@ , " }" , "}" ] - [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |] + [e| handleForeignCatch $ \ $(varP basePtrVarName) -> $(quoteExp block inlineCStr) |] -- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@. -- Using this will automatically include @exception@, @cstring@ and @cstdlib@. tryBlock :: QuasiQuoter tryBlock = QuasiQuoter - { quoteExp = tryBlockQuoteExp + { quoteExp = tryBlockQuoteExp C.block , quotePat = unsupported , quoteType = unsupported , quoteDec = unsupported diff --git a/src/Language/C/Inline/Cpp/Unsafe.hs b/src/Language/C/Inline/Cpp/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Language/C/Inline/Cpp/Unsafe.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Language.C.Inline.Cpp.Unsafe + ( throwBlock + , tryBlock + , catchBlock + , toSomeException + ) where + +import Control.Exception.Safe +import qualified Language.C.Inline.Unsafe as Unsafe +import Language.Haskell.TH.Quote +import Language.C.Inline.Cpp.Exception (tryBlockQuoteExp) +import Language.C.Inline.Cpp.Exception (tryBlockQuoteExp,toSomeException) + +-- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning +-- them in an 'Either' +throwBlock :: QuasiQuoter +throwBlock = QuasiQuoter + { quoteExp = \blockStr -> do + [e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp Unsafe.block blockStr) |] + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." + +-- | Variant of 'throwBlock' for blocks which return 'void'. +catchBlock :: QuasiQuoter +catchBlock = QuasiQuoter + { quoteExp = \blockStr -> quoteExp throwBlock ("void {" ++ blockStr ++ "}") + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." + +-- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@. +-- Using this will automatically include @exception@, @cstring@ and @cstdlib@. +tryBlock :: QuasiQuoter +tryBlock = QuasiQuoter + { quoteExp = tryBlockQuoteExp Unsafe.block + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -41,10 +41,12 @@ data Test data Array a +data Tuple a C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [ ("Test::Test", [t|Test|]), - ("std::array", [t|Array|]) + ("std::array", [t|Array|]), + ("std::tuple", [t|Tuple|]) ] `mappend` StdVector.stdVectorCtx C.include "" @@ -105,6 +107,14 @@ std::cout << (*$(std::array* pt))[0] << std::endl; } |] + Hspec.it "Template with 6 arguments" $ do + pt <- [C.block| std::tuple* { + return NULL; + } |] :: IO (Ptr (Tuple '(C.CInt,C.CInt,C.CInt,C.CInt,C.CInt,C.CInt))) + [C.block| void { + $(std::tuple* pt) = NULL; + } |] + Hspec.describe "Exception handling" $ do Hspec.it "std::exceptions are caught" $ do result <- try [C.catchBlock| @@ -119,6 +129,13 @@ |] result `shouldBeCppOtherException` (Just "unsigned int") + + Hspec.it "non-exceptions are caught (void *)" $ do + result <- try [C.catchBlock| + throw (void *)0xDEADBEEF; + |] + + result `shouldBeCppOtherException` (Just "void*") Hspec.it "non-exceptions are caught (std::string)" $ do result <- try [C.catchBlock|