Skip to content

Commit 18cdcb0

Browse files
roberthroberth
committed
Rethrow Haskell exceptions
 - Removes instances Eq CppException, Ord CppException because those can not be implemented for the CppHaskellException SomeException constructor. - Currently requires significant boilerplate to actually throw a Haskell exception, but at least it can be done.
1 parent 072d624 commit 18cdcb0

File tree

7 files changed

+179
-22
lines changed

7 files changed

+179
-22
lines changed

‎inline-c-cpp/cxx-src/HaskellException.cxx

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
2+
#include "HaskellException.hxx"
3+
4+
HaskellException::HaskellException(std::string renderedExceptionIn, void *haskellExceptionStablePtrIn)
5+
: renderedException(renderedExceptionIn)
6+
, haskellExceptionStablePtr(new HaskellStablePtr(haskellExceptionStablePtrIn))
7+
{
8+
}
9+
10+
HaskellException::HaskellException(const HaskellException &other)
11+
: renderedException(other.renderedException)
12+
, haskellExceptionStablePtr(other.haskellExceptionStablePtr)
13+
{
14+
}
15+
16+
const char* HaskellException::what() const noexcept {
17+
return renderedException.c_str();
18+
}

‎inline-c-cpp/cxx-src/HaskellStablePtr.cxx

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
2+
#include "HaskellStablePtr.hxx"
3+
#include "HsFFI.h"
4+
5+
HaskellStablePtr::~HaskellStablePtr() {
6+
hs_free_stable_ptr(stablePtr);
7+
}

‎inline-c-cpp/include/HaskellException.hxx

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
2+
#pragma once
3+
4+
#include "HaskellStablePtr.hxx"
5+
#include <memory>
6+
#include <string>
7+
8+
class HaskellException : public std::exception {
9+
public:
10+
std::shared_ptr<HaskellStablePtr> haskellExceptionStablePtr;
11+
std::string renderedException;
12+
13+
HaskellException(std::string renderedException, void *haskellExceptionStablePtr);
14+
HaskellException(const HaskellException &);
15+
virtual const char* what() const noexcept override;
16+
17+
};

‎inline-c-cpp/include/HaskellStablePtr.hxx

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
2+
#pragma once
3+
4+
struct HaskellStablePtr {
5+
void *stablePtr;
6+
7+
/* Takes ownership of a stable pointer */
8+
inline HaskellStablePtr(void *s) {
9+
stablePtr = s;
10+
}
11+
/* Calls hs_free_stable_ptr */
12+
~HaskellStablePtr();
13+
};

‎inline-c-cpp/inline-c-cpp.cabal

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1+
cabal-version: 2.1
12
name: inline-c-cpp
2-
version: 0.3.0.2
3+
version: 0.4.0.0
34
synopsis: Lets you embed C++ code into Haskell.
45
description: Utilities to inline C++ code into Haskell using inline-c. See
56
tests for example on how to build.
@@ -11,7 +12,6 @@ copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 France
1112
category: FFI
1213
tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5
1314
build-type: Simple
14-
cabal-version: >=1.10
1515

1616
source-repository head
1717
type: git
@@ -27,6 +27,10 @@ library
2727
hs-source-dirs: src
2828
default-language: Haskell2010
2929
ghc-options: -Wall -optc-std=c++11
30+
include-dirs: include
31+
install-includes: HaskellException.hxx HaskellStablePtr.hxx
32+
cxx-sources: cxx-src/HaskellException.cxx cxx-src/HaskellStablePtr.cxx
33+
extra-libraries: stdc++
3034
if os(darwin)
3135
-- avoid https://gitlab.haskell.org/ghc/ghc/issues/11829
3236
ld-options: -Wl,-keep_dwarf_unwind

‎inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs

Lines changed: 41 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,11 @@
22

33
{-# LANGUAGE TemplateHaskell #-}
44
{-# LANGUAGE PatternSynonyms #-}
5+
{-# LANGUAGE QuasiQuotes #-}
56

67
module Language.C.Inline.Cpp.Exceptions
78
( CppException(..)
9+
, toSomeException
810
, throwBlock
911
, tryBlock
1012
, catchBlock
@@ -13,16 +15,26 @@ module Language.C.Inline.Cpp.Exceptions
1315
import Control.Exception.Safe
1416
import qualified Language.C.Inline as C
1517
import qualified Language.C.Inline.Internal as C
18+
import qualified Language.C.Inline.Cpp as Cpp
1619
import Language.Haskell.TH
1720
import Language.Haskell.TH.Quote
1821
import Foreign
1922
import Foreign.C
2023

24+
C.context Cpp.cppCtx
25+
C.include "HaskellException.hxx"
26+
2127
-- | An exception thrown in C++ code.
2228
data CppException
2329
= CppStdException String
2430
| CppOtherException (Maybe String) -- contains the exception type, if available.
25-
deriving (Eq, Ord, Show)
31+
| CppHaskellException SomeException
32+
deriving (Show)
33+
34+
-- | Like 'toException' but unwrap 'CppHaskellException'
35+
toSomeException :: CppException -> SomeException
36+
toSomeException (CppHaskellException e) = e
37+
toSomeException x = toException x
2638

2739
instance Exception CppException
2840

@@ -33,20 +45,24 @@ pattern ExTypeNoException = 0
3345
pattern ExTypeStdException :: CInt
3446
pattern ExTypeStdException = 1
3547

48+
pattern ExTypeHaskellException :: CInt
49+
pattern ExTypeHaskellException = 2
50+
3651
pattern ExTypeOtherException :: CInt
37-
pattern ExTypeOtherException = 2
52+
pattern ExTypeOtherException = 3
3853

39-
handleForeignCatch :: (Ptr CInt -> Ptr CString -> IO a) -> IO (Either CppException a)
54+
handleForeignCatch :: (Ptr CInt -> Ptr CString -> Ptr (Ptr ()) -> IO a) -> IO (Either CppException a)
4055
handleForeignCatch cont =
4156
alloca $ \exTypePtr ->
42-
alloca $ \msgPtrPtr -> do
57+
alloca $ \msgPtrPtr ->
58+
alloca $ \haskellExPtrPtr -> do
4359
poke exTypePtr ExTypeNoException
4460
-- we need to mask this entire block because the C++ allocates the
4561
-- string for the exception message and we need to make sure that
4662
-- we free it (see the @free@ below). The foreign code would not be
4763
-- preemptable anyway, so I do not think this loses us anything.
4864
mask_ $ do
49-
res <- cont exTypePtr msgPtrPtr
65+
res <- cont exTypePtr msgPtrPtr haskellExPtrPtr
5066
exType <- peek exTypePtr
5167
case exType of
5268
ExTypeNoException -> return (Right res)
@@ -55,6 +71,16 @@ handleForeignCatch cont =
5571
errMsg <- peekCString msgPtr
5672
free msgPtr
5773
return (Left (CppStdException errMsg))
74+
ExTypeHaskellException -> do
75+
haskellExPtr <- peek haskellExPtrPtr
76+
stablePtr <- [C.block| void * {
77+
return (static_cast<HaskellException *>($(void *haskellExPtr)))->haskellExceptionStablePtr->stablePtr;
78+
} |]
79+
someExc <- deRefStablePtr (castPtrToStablePtr stablePtr)
80+
[C.block| void{
81+
delete static_cast<HaskellException *>($(void *haskellExPtr));
82+
} |]
83+
return (Left (CppHaskellException someExc))
5884
ExTypeOtherException -> do
5985
msgPtr <- peek msgPtrPtr
6086
mbExcType <- if msgPtr == nullPtr
@@ -66,12 +92,12 @@ handleForeignCatch cont =
6692
return (Left (CppOtherException mbExcType))
6793
_ -> error "Unexpected C++ exception type."
6894

69-
-- | Like 'tryBlock', but will throw 'CppException's rather than returning
95+
-- | Like 'tryBlock', but will throw unwrapped 'CppHaskellException's or other 'CppException's rather than returning
7096
-- them in an 'Either'
7197
throwBlock :: QuasiQuoter
7298
throwBlock = QuasiQuoter
7399
{ quoteExp = \blockStr -> do
74-
[e| either throwIO return =<< $(tryBlockQuoteExp blockStr) |]
100+
[e| either (throwIO . toSomeException) return =<< $(tryBlockQuoteExp blockStr) |]
75101
, quotePat = unsupported
76102
, quoteType = unsupported
77103
, quoteDec = unsupported
@@ -95,6 +121,7 @@ tryBlockQuoteExp blockStr = do
95121
_ <- C.include "<exception>"
96122
_ <- C.include "<cstring>"
97123
_ <- C.include "<cstdlib>"
124+
_ <- C.include "HaskellException.hxx"
98125
-- see
99126
-- <https://stackoverflow.com/questions/28166565/detect-gcc-as-opposed-to-msvc-clang-with-macro>
100127
-- regarding how to detect g++ or clang.
@@ -109,15 +136,21 @@ tryBlockQuoteExp blockStr = do
109136
]
110137
typePtrVarName <- newName "exTypePtr"
111138
msgPtrVarName <- newName "msgPtr"
139+
haskellExPtrVarName <- newName "haskellExPtr"
112140
-- see
113141
-- <https://stackoverflow.com/questions/561997/determining-exception-type-after-the-exception-is-caught/47164539#47164539>
114142
-- regarding how to show the type of an exception.
115143
let inlineCStr = unlines
116144
[ ty ++ " {"
117145
, " int* __inline_c_cpp_exception_type__ = $(int* " ++ nameBase typePtrVarName ++ ");"
118146
, " char** __inline_c_cpp_error_message__ = $(char** " ++ nameBase msgPtrVarName ++ ");"
147+
, " HaskellException** __inline_c_cpp_haskellexception__ = (HaskellException**)($(void ** " ++ nameBase haskellExPtrVarName ++ "));"
119148
, " try {"
120149
, body
150+
, " } catch (HaskellException &e) {"
151+
, " *__inline_c_cpp_exception_type__ = " ++ show ExTypeHaskellException ++ ";"
152+
, " *__inline_c_cpp_haskellexception__ = new HaskellException(e);"
153+
, if ty == "void" then "return;" else "return {};"
121154
, " } catch (std::exception &e) {"
122155
, " *__inline_c_cpp_exception_type__ = " ++ show ExTypeStdException ++ ";"
123156
, "#if defined(__GNUC__) || defined(__clang__)"
@@ -146,7 +179,7 @@ tryBlockQuoteExp blockStr = do
146179
, " }"
147180
, "}"
148181
]
149-
[e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(quoteExp C.block inlineCStr) |]
182+
[e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) $(varP haskellExPtrVarName) -> $(quoteExp C.block inlineCStr) |]
150183

151184
-- | 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 @{}@.
152185
-- Using this will automatically include @exception@, @cstring@ and @cstdlib@.

0 commit comments

Comments
 (0)