From b40c3dd850980862e4b567caa8eb2750a863a199 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 18 Jan 2022 11:54:11 +0100 Subject: [PATCH 1/3] Preserve exceptions to be handled in C++ --- inline-c-cpp/cxx-src/HaskellException.cxx | 21 ++-- inline-c-cpp/include/HaskellException.hxx | 4 +- inline-c-cpp/inline-c-cpp.cabal | 5 +- inline-c-cpp/src/Language/C/Inline/Cpp.hs | 9 ++ .../src/Language/C/Inline/Cpp/Exceptions.hs | 108 +++++++++++++----- inline-c-cpp/test/tests.hs | 25 +++- 6 files changed, 127 insertions(+), 45 deletions(-) diff --git a/inline-c-cpp/cxx-src/HaskellException.cxx b/inline-c-cpp/cxx-src/HaskellException.cxx index f0cd6c5..00fb98c 100644 --- a/inline-c-cpp/cxx-src/HaskellException.cxx +++ b/inline-c-cpp/cxx-src/HaskellException.cxx @@ -54,25 +54,18 @@ const char* currentExceptionTypeName() } #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 setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typStrPtr){ + *msgStrPtr = strdup(e.what()); + setCppExceptionType(typStrPtr); } -void setMessageOfOtherException(char** __inline_c_cpp_error_message__){ +void setCppExceptionType(char** typStrPtr){ #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); + *typStrPtr = static_cast(std::malloc(message_len)); + std::memcpy(*typStrPtr, message, message_len); #else - *__inline_c_cpp_error_message__ = NULL; + *typStrPtr = NULL; #endif } diff --git a/inline-c-cpp/include/HaskellException.hxx b/inline-c-cpp/include/HaskellException.hxx index 04ba276..6becc95 100644 --- a/inline-c-cpp/include/HaskellException.hxx +++ b/inline-c-cpp/include/HaskellException.hxx @@ -36,5 +36,5 @@ public: }; -void setMessageOfStdException(std::exception &e,char** __inline_c_cpp_error_message__); -void setMessageOfOtherException(char** __inline_c_cpp_error_message__); +void setMessageOfStdException(const std::exception &e, char** msgStrPtr, char **typeStrPtr); +void setCppExceptionType(char** typeStrPtr); diff --git a/inline-c-cpp/inline-c-cpp.cabal b/inline-c-cpp/inline-c-cpp.cabal index 9645dd7..1649381 100644 --- a/inline-c-cpp/inline-c-cpp.cabal +++ b/inline-c-cpp/inline-c-cpp.cabal @@ -62,8 +62,10 @@ library exposed-modules: Language.C.Inline.Cpp Language.C.Inline.Cpp.Exceptions build-depends: base >=4.7 && <5 + , bytestring , inline-c >= 0.9.0.0 , template-haskell + , text , safe-exceptions , containers hs-source-dirs: src @@ -82,6 +84,7 @@ test-suite tests other-modules: StdVector , TemplateSpec build-depends: base >=4 && <5 + , bytestring , inline-c , inline-c-cpp , safe-exceptions @@ -90,7 +93,7 @@ test-suite tests , template-haskell , vector default-language: Haskell2010 - cxx-options: -Werror + cxx-options: -Werror -std=c++11 if impl(ghc >= 8.10) ghc-options: diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp.hs b/inline-c-cpp/src/Language/C/Inline/Cpp.hs index 0d99024..df4eb13 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + -- | Module exposing a 'Context' to inline C++ code. We only have used -- this for experiments, so use with caution. See the C++ tests to see -- how to build inline C++ code. @@ -6,6 +10,7 @@ module Language.C.Inline.Cpp , cppCtx , cppTypePairs , using + , AbstractCppExceptionPtr ) where import Data.Monoid ((<>), mempty) @@ -27,8 +32,12 @@ cppCtx = baseCtx <> mempty { ctxForeignSrcLang = Just TH.LangCxx , ctxOutput = Just $ \s -> "extern \"C\" {\n" ++ s ++ "\n}" , ctxEnableCpp = True + , ctxTypesTable = Map.singleton (CT.TypeName "std::exception_ptr") [t|AbstractCppExceptionPtr|] } +-- | Marks an @std::exception_ptr@. Only used via 'Ptr'. +data AbstractCppExceptionPtr + -- | Emits an @using@ directive, e.g. -- -- @ diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs index 5a4b9b1..9a57dab 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs @@ -2,10 +2,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE QuasiQuotes #-} module Language.C.Inline.Cpp.Exceptions ( CppException(..) + , pattern CppStdException + , pattern CppOtherException , toSomeException , throwBlock , tryBlock @@ -13,31 +16,60 @@ module Language.C.Inline.Cpp.Exceptions ) where import Control.Exception.Safe +import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString) +import Data.ByteString (ByteString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Language.C.Inline as C import qualified Language.C.Inline.Internal as C import qualified Language.C.Inline.Cpp as Cpp +import Language.C.Inline.Cpp (AbstractCppExceptionPtr) import Language.Haskell.TH import Language.Haskell.TH.Quote import Foreign import Foreign.C +import System.IO.Unsafe(unsafePerformIO) C.context Cpp.cppCtx C.include "HaskellException.hxx" -- | An exception thrown in C++ code. data CppException - = CppStdException String - | CppOtherException (Maybe String) -- contains the exception type, if available. + = CppStdException' CppExceptionPtr ByteString (Maybe ByteString) | CppHaskellException SomeException - deriving (Show) + | CppNonStdException CppExceptionPtr (Maybe ByteString) + +instance Show CppException where + showsPrec p (CppStdException' _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showsPrec 11 typ) + showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e) + showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ) + +instance Exception CppException where + displayException (CppStdException' _ msg _typ) = bsToChars msg + displayException (CppHaskellException e) = displayException e + displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ + displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type" + +type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr + +unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr +unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p + +finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr +{-# NOINLINE finalizeAbstractCppExceptionPtr #-} +finalizeAbstractCppExceptionPtr = + unsafePerformIO + [C.exp| + void (*)(std::exception_ptr *) { + [](std::exception_ptr *v){ delete v; } + }|] -- | Like 'toException' but unwrap 'CppHaskellException' toSomeException :: CppException -> SomeException toSomeException (CppHaskellException e) = e toSomeException x = toException x -instance Exception CppException - -- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future. pattern ExTypeNoException :: CInt pattern ExTypeNoException = 0 @@ -51,10 +83,13 @@ pattern ExTypeHaskellException = 2 pattern ExTypeOtherException :: CInt pattern ExTypeOtherException = 3 -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) + +handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) handleForeignCatch cont = alloca $ \exTypePtr -> - alloca $ \msgPtrPtr -> + alloca $ \msgCStringPtr -> + alloca $ \typCStringPtr -> + alloca $ \exPtr -> alloca $ \haskellExPtrPtr -> do poke exTypePtr ExTypeNoException -- we need to mask this entire block because the C++ allocates the @@ -62,15 +97,15 @@ handleForeignCatch cont = -- 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 msgPtrPtr haskellExPtrPtr + res <- cont exTypePtr msgCStringPtr typCStringPtr exPtr haskellExPtrPtr exType <- peek exTypePtr case exType of ExTypeNoException -> return (Right res) ExTypeStdException -> do - msgPtr <- peek msgPtrPtr - errMsg <- peekCString msgPtr - free msgPtr - return (Left (CppStdException errMsg)) + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppStdException' ex errMsg mbExcType)) ExTypeHaskellException -> do haskellExPtr <- peek haskellExPtrPtr stablePtr <- [C.block| void * { @@ -82,14 +117,9 @@ handleForeignCatch cont = } |] return (Left (CppHaskellException someExc)) ExTypeOtherException -> do - msgPtr <- peek msgPtrPtr - mbExcType <- if msgPtr == nullPtr - then return Nothing - else do - excType <- peekCString msgPtr - free msgPtr - return (Just excType) - return (Left (CppOtherException mbExcType)) + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) _ -> error "Unexpected C++ exception type." -- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning @@ -165,30 +195,36 @@ tryBlockQuoteExp blockStr = do typePtrVarName <- newName "exTypePtr" msgPtrVarName <- newName "msgPtr" haskellExPtrVarName <- newName "haskellExPtr" + exPtrVarName <- newName "exPtr" + typeStrPtrVarName <- newName "typeStrPtr" 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 ++ ");" , " try {" , body - , " } catch (HaskellException &e) {" + , " } catch (const HaskellException &e) {" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" , " return " ++ exceptionalValue ty ++ ";" - , " } catch (std::exception &e) {" + , " } catch (const std::exception &e) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" - , " setMessageOfStdException(e,__inline_c_cpp_error_message__);" + , " setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);" , " return " ++ exceptionalValue ty ++ ";" , " } catch (...) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" - , " setMessageOfOtherException(__inline_c_cpp_error_message__);" + , " setCppExceptionType(__inline_c_cpp_error_typ__);" , " return " ++ exceptionalValue ty ++ ";" , " }" , "}" ] - [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |] - + [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.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 @@ -199,3 +235,23 @@ tryBlock = QuasiQuoter , quoteDec = unsupported } where unsupported _ = fail "Unsupported quasiquotation." + +bsToChars :: ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode + +-- legacy -- + +pattern CppStdException :: String -> CppException +pattern CppStdException s <- (cppStdExceptionMessage -> Just s) + +pattern CppOtherException :: Maybe String -> CppException +pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt) + +cppStdExceptionMessage :: CppException -> Maybe String +cppStdExceptionMessage (CppStdException' _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t +cppStdExceptionMessage (CppStdException' _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)" +cppStdExceptionMessage _ = Nothing + +cppNonStdExceptionType :: CppException -> Maybe (Maybe String) +cppNonStdExceptionType (CppNonStdException _ mt) = Just (fmap bsToChars mt) +cppNonStdExceptionType _ = Nothing diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index 1d4127a..d1e20b0 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -17,9 +17,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} import Control.Exception.Safe import Control.Monad +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Context as CC import qualified Language.C.Types as CT @@ -34,10 +37,11 @@ import Data.Monoid import qualified StdVector import qualified Data.Vector.Storable as VS + data Test data Array a -C.context $ C.cppCtx `mappend` C.cppTypePairs [ +C.context $ C.cppCtx <> C.fptrCtx <> C.cppTypePairs [ ("Test::Test", [t|Test|]), ("std::array", [t|Array|]) ] `mappend` StdVector.stdVectorCtx @@ -121,7 +125,24 @@ main = Hspec.hspec $ do |] case result of - Left (C.CppOtherException (Just ty)) | "string" `isInfixOf` ty -> return () + Left (C.CppNonStdException ex (Just ty)) -> do + ("string" `BS.isInfixOf` ty) `shouldBe` True + [C.throwBlock| int { + std::exception_ptr *e = $fptr-ptr:(std::exception_ptr *ex); + if (!e) throw std::runtime_error("Exception was null"); + try { + std::cerr << "throwing..." << std::endl; + std::rethrow_exception(*e); + } catch (std::string &foobar) { + if (foobar == "FOOBAR") + return 42; + else + return 1; + } catch (...) { + return 2; + } + return 3; + }|] >>= \r -> r `shouldBe` 42 _ -> error ("Expected Left CppOtherException with string type, but got " ++ show result) Hspec.it "catch without return (pure)" $ do From e43b59a073b3f9df216f204d384b0d112444df13 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 18 Jan 2022 12:02:52 +0100 Subject: [PATCH 2/3] Move new exception code into module, improve backcompat somewhat --- inline-c-cpp/inline-c-cpp.cabal | 1 + .../src/Language/C/Inline/Cpp/Exception.hs | 238 +++++++++++++++++ .../src/Language/C/Inline/Cpp/Exceptions.hs | 251 ++---------------- inline-c-cpp/test/tests.hs | 9 +- 4 files changed, 259 insertions(+), 240 deletions(-) create mode 100644 inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs diff --git a/inline-c-cpp/inline-c-cpp.cabal b/inline-c-cpp/inline-c-cpp.cabal index 1649381..fa09e48 100644 --- a/inline-c-cpp/inline-c-cpp.cabal +++ b/inline-c-cpp/inline-c-cpp.cabal @@ -60,6 +60,7 @@ common cxx-opts library import: cxx-opts exposed-modules: Language.C.Inline.Cpp + Language.C.Inline.Cpp.Exception Language.C.Inline.Cpp.Exceptions build-depends: base >=4.7 && <5 , bytestring diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs new file mode 100644 index 0000000..7b80f60 --- /dev/null +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs @@ -0,0 +1,238 @@ +-- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Language.C.Inline.Cpp.Exception + ( CppException(..) + , toSomeException + , throwBlock + , tryBlock + , catchBlock + ) where + +import Control.Exception.Safe +import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString) +import Data.ByteString (ByteString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Internal as C +import qualified Language.C.Inline.Cpp as Cpp +import Language.C.Inline.Cpp (AbstractCppExceptionPtr) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Foreign +import Foreign.C +import System.IO.Unsafe(unsafePerformIO) + +C.context Cpp.cppCtx +C.include "HaskellException.hxx" + +-- | An exception thrown in C++ code. +data CppException + = CppStdException CppExceptionPtr ByteString (Maybe ByteString) + | CppHaskellException SomeException + | CppNonStdException CppExceptionPtr (Maybe ByteString) + +instance Show CppException where + showsPrec p (CppStdException _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showsPrec 11 typ) + showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e) + showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ) + +instance Exception CppException where + displayException (CppStdException _ msg _typ) = bsToChars msg + displayException (CppHaskellException e) = displayException e + displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ + displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type" + +type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr + +unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr +unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p + +finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr +{-# NOINLINE finalizeAbstractCppExceptionPtr #-} +finalizeAbstractCppExceptionPtr = + unsafePerformIO + [C.exp| + void (*)(std::exception_ptr *) { + [](std::exception_ptr *v){ delete v; } + }|] + +-- | Like 'toException' but unwrap 'CppHaskellException' +toSomeException :: CppException -> SomeException +toSomeException (CppHaskellException e) = e +toSomeException x = toException x + +-- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future. +pattern ExTypeNoException :: CInt +pattern ExTypeNoException = 0 + +pattern ExTypeStdException :: CInt +pattern ExTypeStdException = 1 + +pattern ExTypeHaskellException :: CInt +pattern ExTypeHaskellException = 2 + +pattern ExTypeOtherException :: CInt +pattern ExTypeOtherException = 3 + + +handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) +handleForeignCatch cont = + alloca $ \exTypePtr -> + alloca $ \msgCStringPtr -> + alloca $ \typCStringPtr -> + alloca $ \exPtr -> + alloca $ \haskellExPtrPtr -> do + poke exTypePtr ExTypeNoException + -- 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 + exType <- peek exTypePtr + case exType of + ExTypeNoException -> return (Right res) + ExTypeStdException -> do + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppStdException ex errMsg mbExcType)) + ExTypeHaskellException -> do + haskellExPtr <- peek haskellExPtrPtr + stablePtr <- [C.block| void * { + return (static_cast($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr; + } |] + someExc <- deRefStablePtr (castPtrToStablePtr stablePtr) + [C.block| void{ + delete static_cast($(void *haskellExPtr)); + } |] + return (Left (CppHaskellException someExc)) + ExTypeOtherException -> do + ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr + mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr + return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) + _ -> error "Unexpected C++ exception type." + +-- | 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 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." + +exceptionalValue :: String -> String +exceptionalValue typeStr = + case typeStr of + "void" -> "" + "char" -> "0" + "short" -> "0" + "long" -> "0" + "int" -> "0" + "int8_t" -> "0" + "int16_t" -> "0" + "int32_t" -> "0" + "int64_t" -> "0" + "uint8_t" -> "0" + "uint16_t" -> "0" + "uint32_t" -> "0" + "uint64_t" -> "0" + "float" -> "0" + "double" -> "0" + "bool" -> "0" + "signed char" -> "0" + "signed short" -> "0" + "signed int" -> "0" + "signed long" -> "0" + "unsigned char" -> "0" + "unsigned short" -> "0" + "unsigned int" -> "0" + "unsigned long" -> "0" + "size_t" -> "0" + "wchar_t" -> "0" + "ptrdiff_t" -> "0" + "sig_atomic_t" -> "0" + "intptr_t" -> "0" + "uintptr_t" -> "0" + "intmax_t" -> "0" + "uintmax_t" -> "0" + "clock_t" -> "0" + "time_t" -> "0" + "useconds_t" -> "0" + "suseconds_t" -> "0" + "FILE" -> "0" + "fpos_t" -> "0" + "jmp_buf" -> "0" + _ -> "{}" + +tryBlockQuoteExp :: String -> Q Exp +tryBlockQuoteExp 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" + 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 ++ ");" + , " try {" + , body + , " } catch (const HaskellException &e) {" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" + , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" + , " return " ++ exceptionalValue ty ++ ";" + , " } catch (const std::exception &e) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" + , " setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);" + , " return " ++ exceptionalValue ty ++ ";" + , " } catch (...) {" + , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" + , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" + , " setCppExceptionType(__inline_c_cpp_error_typ__);" + , " return " ++ exceptionalValue ty ++ ";" + , " }" + , "}" + ] + [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.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 + , quotePat = unsupported + , quoteType = unsupported + , quoteDec = unsupported + } where + unsupported _ = fail "Unsupported quasiquotation." + +bsToChars :: ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs index 9a57dab..ac07d77 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs @@ -1,257 +1,36 @@ --- | A module that contains exception-safe equivalents of @inline-c@ QuasiQuoters. - -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE QuasiQuotes #-} - -module Language.C.Inline.Cpp.Exceptions - ( CppException(..) - , pattern CppStdException - , pattern CppOtherException +module Language.C.Inline.Cpp.Exceptions {-# DEPRECATED "Language.C.Inline.Cpp.Exceptions is deprecated in favor of Language.C.Inline.Cpp.Exception which changes the CppException data type to preserve the exception for custom error handling." #-} ( + CppException(CppHaskellException) + , pattern Language.C.Inline.Cpp.Exceptions.CppStdException + , pattern Language.C.Inline.Cpp.Exceptions.CppOtherException , toSomeException , throwBlock , tryBlock , catchBlock ) where -import Control.Exception.Safe -import qualified Data.ByteString.Unsafe as BS (unsafePackMallocCString) + import Data.ByteString (ByteString) -import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T -import qualified Language.C.Inline as C -import qualified Language.C.Inline.Internal as C -import qualified Language.C.Inline.Cpp as Cpp -import Language.C.Inline.Cpp (AbstractCppExceptionPtr) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Foreign -import Foreign.C -import System.IO.Unsafe(unsafePerformIO) - -C.context Cpp.cppCtx -C.include "HaskellException.hxx" - --- | An exception thrown in C++ code. -data CppException - = CppStdException' CppExceptionPtr ByteString (Maybe ByteString) - | CppHaskellException SomeException - | CppNonStdException CppExceptionPtr (Maybe ByteString) - -instance Show CppException where - showsPrec p (CppStdException' _ msg typ) = showParen (p >= 11) (showString "CppStdException e " . showsPrec 11 msg . showsPrec 11 typ) - showsPrec p (CppHaskellException e) = showParen (p >= 11) (showString "CppHaskellException " . showsPrec 11 e) - showsPrec p (CppNonStdException _ typ) = showParen (p >= 11) (showString "CppOtherException e " . showsPrec 11 typ) - -instance Exception CppException where - displayException (CppStdException' _ msg _typ) = bsToChars msg - displayException (CppHaskellException e) = displayException e - displayException (CppNonStdException _ (Just typ)) = "exception: Exception of type " <> bsToChars typ - displayException (CppNonStdException _ Nothing) = "exception: Non-std exception of unknown type" - -type CppExceptionPtr = ForeignPtr AbstractCppExceptionPtr - -unsafeFromNewCppExceptionPtr :: Ptr AbstractCppExceptionPtr -> IO CppExceptionPtr -unsafeFromNewCppExceptionPtr p = newForeignPtr finalizeAbstractCppExceptionPtr p - -finalizeAbstractCppExceptionPtr :: FinalizerPtr AbstractCppExceptionPtr -{-# NOINLINE finalizeAbstractCppExceptionPtr #-} -finalizeAbstractCppExceptionPtr = - unsafePerformIO - [C.exp| - void (*)(std::exception_ptr *) { - [](std::exception_ptr *v){ delete v; } - }|] - --- | Like 'toException' but unwrap 'CppHaskellException' -toSomeException :: CppException -> SomeException -toSomeException (CppHaskellException e) = e -toSomeException x = toException x - --- NOTE: Other C++ exception types (std::runtime_error etc) could be distinguished like this in the future. -pattern ExTypeNoException :: CInt -pattern ExTypeNoException = 0 - -pattern ExTypeStdException :: CInt -pattern ExTypeStdException = 1 - -pattern ExTypeHaskellException :: CInt -pattern ExTypeHaskellException = 2 - -pattern ExTypeOtherException :: CInt -pattern ExTypeOtherException = 3 - - -handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr CString -> Ptr (Ptr AbstractCppExceptionPtr) -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a) -handleForeignCatch cont = - alloca $ \exTypePtr -> - alloca $ \msgCStringPtr -> - alloca $ \typCStringPtr -> - alloca $ \exPtr -> - alloca $ \haskellExPtrPtr -> do - poke exTypePtr ExTypeNoException - -- 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 - exType <- peek exTypePtr - case exType of - ExTypeNoException -> return (Right res) - ExTypeStdException -> do - ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr - errMsg <- BS.unsafePackMallocCString =<< peek msgCStringPtr - mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr - return (Left (CppStdException' ex errMsg mbExcType)) - ExTypeHaskellException -> do - haskellExPtr <- peek haskellExPtrPtr - stablePtr <- [C.block| void * { - return (static_cast($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr; - } |] - someExc <- deRefStablePtr (castPtrToStablePtr stablePtr) - [C.block| void{ - delete static_cast($(void *haskellExPtr)); - } |] - return (Left (CppHaskellException someExc)) - ExTypeOtherException -> do - ex <- unsafeFromNewCppExceptionPtr =<< peek exPtr - mbExcType <- maybePeek BS.unsafePackMallocCString =<< peek typCStringPtr - return (Left (CppNonStdException ex mbExcType)) :: IO (Either CppException a) - _ -> error "Unexpected C++ exception type." - --- | 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 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." - -exceptionalValue :: String -> String -exceptionalValue typeStr = - case typeStr of - "void" -> "" - "char" -> "0" - "short" -> "0" - "long" -> "0" - "int" -> "0" - "int8_t" -> "0" - "int16_t" -> "0" - "int32_t" -> "0" - "int64_t" -> "0" - "uint8_t" -> "0" - "uint16_t" -> "0" - "uint32_t" -> "0" - "uint64_t" -> "0" - "float" -> "0" - "double" -> "0" - "bool" -> "0" - "signed char" -> "0" - "signed short" -> "0" - "signed int" -> "0" - "signed long" -> "0" - "unsigned char" -> "0" - "unsigned short" -> "0" - "unsigned int" -> "0" - "unsigned long" -> "0" - "size_t" -> "0" - "wchar_t" -> "0" - "ptrdiff_t" -> "0" - "sig_atomic_t" -> "0" - "intptr_t" -> "0" - "uintptr_t" -> "0" - "intmax_t" -> "0" - "uintmax_t" -> "0" - "clock_t" -> "0" - "time_t" -> "0" - "useconds_t" -> "0" - "suseconds_t" -> "0" - "FILE" -> "0" - "fpos_t" -> "0" - "jmp_buf" -> "0" - _ -> "{}" - -tryBlockQuoteExp :: String -> Q Exp -tryBlockQuoteExp 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" - 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 ++ ");" - , " try {" - , body - , " } catch (const HaskellException &e) {" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";" - , " *__inline_c_cpp_haskellexception__ = new HaskellException(e);" - , " return " ++ exceptionalValue ty ++ ";" - , " } catch (const std::exception &e) {" - , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";" - , " setMessageOfStdException(e, __inline_c_cpp_error_message__, __inline_c_cpp_error_typ__);" - , " return " ++ exceptionalValue ty ++ ";" - , " } catch (...) {" - , " *__inline_c_cpp_exception_ptr__ = new std::exception_ptr(std::current_exception());" - , " *__inline_c_cpp_exception_type__ = " ++ show ExTypeOtherException ++ ";" - , " setCppExceptionType(__inline_c_cpp_error_typ__);" - , " return " ++ exceptionalValue ty ++ ";" - , " }" - , "}" - ] - [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP typeStrPtrVarName) $(varP exPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.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 - , quotePat = unsupported - , quoteType = unsupported - , quoteDec = unsupported - } where - unsupported _ = fail "Unsupported quasiquotation." +import qualified Data.Text as T +import Language.C.Inline.Cpp.Exception bsToChars :: ByteString -> String bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode --- legacy -- - -pattern CppStdException :: String -> CppException -pattern CppStdException s <- (cppStdExceptionMessage -> Just s) - -pattern CppOtherException :: Maybe String -> CppException -pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt) - cppStdExceptionMessage :: CppException -> Maybe String -cppStdExceptionMessage (CppStdException' _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t -cppStdExceptionMessage (CppStdException' _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)" +cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s (Just t)) = Just $ "Exception: " <> bsToChars s <> "; type: " <> bsToChars t +cppStdExceptionMessage (Language.C.Inline.Cpp.Exception.CppStdException _ s Nothing) = Just $ "Exception: " <> bsToChars s <> "; type: not available (please use g++ or clang)" cppStdExceptionMessage _ = Nothing cppNonStdExceptionType :: CppException -> Maybe (Maybe String) cppNonStdExceptionType (CppNonStdException _ mt) = Just (fmap bsToChars mt) cppNonStdExceptionType _ = Nothing + +pattern CppStdException :: String -> CppException +pattern CppStdException s <- (cppStdExceptionMessage -> Just s) + +pattern CppOtherException :: Maybe String -> CppException +pattern CppOtherException mt <- (cppNonStdExceptionType -> Just mt) diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index d1e20b0..2262247 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -26,7 +26,8 @@ import Data.ByteString (ByteString) import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Context as CC import qualified Language.C.Types as CT -import qualified Language.C.Inline.Cpp.Exceptions as C +import qualified Language.C.Inline.Cpp.Exception as C +import qualified Language.C.Inline.Cpp.Exceptions as Legacy import Foreign.C.String (withCString) import Foreign.StablePtr (StablePtr, newStablePtr, castStablePtrToPtr) import qualified Test.Hspec as Hspec @@ -296,16 +297,16 @@ main = Hspec.hspec $ do tag :: C.CppException -> String tag (C.CppStdException {}) = "CppStdException" tag (C.CppHaskellException {}) = "CppHaskellException" -tag (C.CppOtherException {}) = "CppStdException" +tag (Legacy.CppOtherException {}) = "CppStdException" shouldBeCppStdException :: Either C.CppException a -> String -> IO () -shouldBeCppStdException (Left (C.CppStdException actualMsg)) expectedMsg = do +shouldBeCppStdException (Left (Legacy.CppStdException actualMsg)) expectedMsg = do actualMsg `Hspec.shouldBe` expectedMsg shouldBeCppStdException (Left x) expectedMsg = tag x `Hspec.shouldBe` ("CppStdException " <> show expectedMsg) shouldBeCppStdException (Right _) expectedMsg = "Right _" `Hspec.shouldBe` ("Left (CppStdException " <> show expectedMsg <> ")") shouldBeCppOtherException :: Either C.CppException a -> Maybe String -> IO () -shouldBeCppOtherException (Left (C.CppOtherException actualType)) expectedType = do +shouldBeCppOtherException (Left (Legacy.CppOtherException actualType)) expectedType = do actualType `Hspec.shouldBe` expectedType shouldBeCppOtherException (Left x) expectedType = tag x `Hspec.shouldBe` ("CppOtherException " <> show expectedType) shouldBeCppOtherException (Right _) expectedType = "Right _" `Hspec.shouldBe` ("Left (CppOtherException " <> show expectedType <> ")") From 8fed64c46c5800140bc8b3bff8e8967c57a16a50 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 18 Jan 2022 14:31:54 +0100 Subject: [PATCH 3/3] Expose CppExceptionPtr --- inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs index 7b80f60..9efbb09 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exception.hs @@ -7,6 +7,7 @@ module Language.C.Inline.Cpp.Exception ( CppException(..) + , CppExceptionPtr , toSomeException , throwBlock , tryBlock