Preserve haskell exceptions from callbacks

ChangeLog.md

@@ -1,3 +1,13 @@
+0.3.0.0 [XXXX.XX.XX]
+--------------------
+* Support for builds with `python3-config`
+* Support for async
+* `inline_python` module is now available.
+* Now haskell exception from haskell callback in converted to
+  `inline_python.HaskellError` and is rethrown if it's not catched by python.
+* Memory leak is fixed. Python exception object were never freed when exception
+  propagated to haskell side.
+
 0.2.1.0 [2026.01.13]
 ----------------
 * `From/ToPy` instance for `Integer`&`Natural` added.
@@ -21,7 +31,7 @@
 0.1.1 [2025.02.13]
 ------------------
 * Number of deadlocks in `runPyInMain` fixed:
-  - It no longer deadlocks is exception is thrown
+  - It no longer deadlocks if exception is thrown
   - Nested calls no longer deadlock.
   - Calling it from python callback.
 * `ToPy` instance added for `Py b`, `a -> Py b`, `a1 -> a2 -> Py b`

cbits/python.c

@@ -246,6 +246,9 @@ void inline_py_initialize(void) {
 // ================================================================
 // inline_python module
 
+PyObject* (*inline_py_haskell_error_repr)(void*);
+PyObject* (*inline_py_haskell_error_tyrepr)(void*);
+
 PyObject* inline_py_AsyncCancelled() {
     static PyObject* AsyncCancelled = 0;
     if( AsyncCancelled == 0 ) {
@@ -254,6 +257,80 @@ PyObject* inline_py_AsyncCancelled() {
     return AsyncCancelled;
 }
 
+typedef struct {
+    PyBaseExceptionObject obj;
+    void *exception_stableptr;
+} HaskellError;
+
+static void haskell_error_dealloc(PyObject *op) {
+    HaskellError *self = (HaskellError*) op;
+    hs_free_stable_ptr(self->exception_stableptr);
+    Py_TYPE(self)->tp_free(self);
+}
+
+static PyObject* haskell_error_repr(PyObject *op) {
+    HaskellError *self = (HaskellError*) op;
+    PyObject* exc_repr = inline_py_haskell_error_repr(self->exception_stableptr);
+    PyObject* exc_ty   = inline_py_haskell_error_tyrepr(self->exception_stableptr);
+    PyObject* repr     = PyUnicode_FromFormat("<inline_python.HaskellError: %S: %S>", exc_ty, exc_repr);
+    Py_DECREF(exc_repr);
+    Py_DECREF(exc_ty);
+    return repr;
+}
+
+static PyTypeObject HaskellError_Type = {
+    PyVarObject_HEAD_INIT(NULL, 0)
+    .tp_name      = "inline_python.HaskellError",
+    .tp_basicsize = sizeof(HaskellError),
+    .tp_flags     = Py_TPFLAGS_DEFAULT | Py_TPFLAGS_DISALLOW_INSTANTIATION,
+    .tp_doc       = PyDoc_STR("Wrapper for a haskell exception object"),
+    .tp_dealloc   = haskell_error_dealloc,
+    .tp_repr      = haskell_error_repr
+};
+
+
+PyObject* inline_py_HaskellError() {
+    static int initialized = 0;
+    if( 0 == initialized ) {
+        if( PyType_Ready(&HaskellError_Type) != 0) {
+            // It should success always and we don't have any reasonable
+            // way of handing error.
+            exit(1);
+        }
+        initialized = 1;
+    }
+    return (PyObject*)&HaskellError_Type;
+}
+
+PyObject* inline_py_HaskellError_create(void* exc_ptr) {
+    PyTypeObject *base = HaskellError_Type.tp_base;
+    PyObject *args     = PyTuple_New(0);
+    // Call __new__
+    PyObject *obj = base->tp_new(&HaskellError_Type, args, NULL);
+    if( !obj ) {
+        goto err;
+    }
+    // Call __init__
+    if( 0 != base->tp_init(obj, args, NULL) ) {
+        goto err;
+    }
+    // Set custom fields
+    HaskellError* h_err = (HaskellError*)obj;
+    h_err->exception_stableptr = exc_ptr;
+    Py_DECREF(args);
+    return obj;
+err:
+    Py_DECREF(args);
+    return NULL;
+}
+
+void* inline_py_HaskellError_get_stableptr(PyObject* err) {
+    HaskellError *h_err = (HaskellError*) err;
+    return h_err->exception_stableptr;
+}
+
+
+
 static PyMethodDef inline_python_methods[] = {
     {NULL, NULL, 0, NULL}
 };
@@ -269,6 +346,12 @@ static int inline_python_module_exec(PyObject *m) {
     if (PyModule_AddObjectRef(m, "AsyncCancelled", inline_py_AsyncCancelled()) < 0) {
         return -1;
     }
+    //
+    HaskellError_Type.tp_base = (PyTypeObject*)PyExc_Exception;
+    HaskellError_Type.tp_new  = NULL;
+    if (PyModule_AddObjectRef(m, "HaskellError", inline_py_HaskellError()) < 0) {
+        return -1;
+    }
     return 0;
 }
 

include/inline-python.h

@@ -105,7 +105,25 @@ void* inline_py_get_state(void);
 // inline_python module
 // ================================================================
 
+// Function pointers to be set from haskell side
+
+// String representation of an exception
+extern PyObject* (*inline_py_haskell_error_repr)(void*);
+// String representation of exception type
+extern PyObject* (*inline_py_haskell_error_tyrepr)(void*);
+
+
 PyMODINIT_FUNC PyInit_inline_python(void);
 
-// Obtain class for async exception
+// Obtain type for async exception.
 PyObject* inline_py_AsyncCancelled();
+
+// Obtain type for wrapper for haskell exceptions.
+PyObject* inline_py_HaskellError();
+
+// Create python object wrapping haskell exception
+PyObject* inline_py_HaskellError_create(void* exc_ptr);
+
+// Get StablePtr held by exception. Python object must be of type
+// HaskellError
+void* inline_py_HaskellError_get_stableptr(PyObject* err);

inline-python.cabal

@@ -69,6 +69,7 @@ Library
   import:            language
   Build-Depends:     base             >=4.15 && <5
                    , primitive        >=0.6.2
+                   , deepseq          >=1.4
                    , vector           >=0.13.2
                    , containers       >=0.5
                    , process

src/Python/Internal/CAPI.hs

@@ -4,6 +4,7 @@
 -- Thin wrappers over C API
 module Python.Internal.CAPI
   ( decref
+  , xdecref
   , incref
     -- * Simple wrappers
   , basicNewDict
@@ -29,6 +30,9 @@ C.include "<inline-python.h>"
 decref :: Ptr PyObject -> Py ()
 decref p = Py [C.exp| void { Py_DECREF($(PyObject* p)) } |]
 
+xdecref :: Ptr PyObject -> Py ()
+xdecref p = Py [C.exp| void { Py_XDECREF($(PyObject* p)) } |]
+
 incref :: Ptr PyObject -> Py ()
 incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]
 

src/Python/Internal/Eval.hs

@@ -55,20 +55,21 @@ module Python.Internal.Eval
 
 import Control.Concurrent
 import Control.Concurrent.STM
-import Control.Exception         (interruptible)
+import Control.Exception         (interruptible,evaluate)
+import Control.DeepSeq
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Cont
 import Data.Maybe
 import Data.Function
 import Data.ByteString.Unsafe    qualified as BS
+import Data.Typeable
 import Foreign.Concurrent        qualified as GHC
 import Foreign.Ptr
 import Foreign.ForeignPtr
 import Foreign.StablePtr
 import Foreign.C.Types
-import Foreign.C.String
 import Foreign.Marshal.Array
 import Foreign.Storable
 import System.Environment
@@ -400,13 +401,16 @@ doInitializePythonIO = do
   argv0 <- getProgName
   argv  <- getArgs
   let n_argv = fromIntegral $ length argv + 1
-  -- FIXME: For some reason sys.argv is initialized incorrectly. No
-  --        easy way to debug. Will do for now
+  hask_err_repr   <- wrapReprFromStablePtr haskellErrorRepr
+  hask_err_tyrepr <- wrapReprFromStablePtr haskellErrorTyRepr
   r <- evalContT $ do
     p_argv0  <- ContT $ withWCString argv0
     p_argv   <- traverse (ContT . withWCString) argv
     ptr_argv <- ContT $ withArray (p_argv0 : p_argv)
     liftIO [C.block| int {
+      // Set global constants
+      inline_py_haskell_error_repr   = $(PyObject* (*hask_err_repr)(void*));
+      inline_py_haskell_error_tyrepr = $(PyObject* (*hask_err_tyrepr)(void*));
       // Now fill config
       PyStatus status;
       PyConfig cfg;
@@ -445,8 +449,12 @@ doInitializePythonIO = do
               PyErr_Clear();
           }
       }
-      // Initialize internals
+      // Initialize internals. We also need to import module with our internals
       inline_py_initialize();
+      PyObject *inline_python = PyImport_ImportModule("inline_python");
+      if( PyErr_Occurred() ) {
+          PyErr_Clear();
+      }
       // Release GIL so other threads may take it
       PyEval_SaveThread();
       return 0;
@@ -457,6 +465,30 @@ doInitializePythonIO = do
       } |]
   return $! r == 0
 
+haskellErrorRepr :: Ptr () -> IO (Ptr PyObject)
+haskellErrorRepr ptr = unsafeRunPy $ runProgram $ do
+  SomeException err <- progIO $ deRefStablePtr $ castPtrToStablePtr ptr
+  -- We need to make sure that we evaluated string so that we won't
+  -- leak exceptions
+  repr  <- progIO $ evaluate $ force $ show err
+  p_str <- withPyWCString repr
+  progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]
+
+haskellErrorTyRepr :: Ptr () -> IO (Ptr PyObject)
+haskellErrorTyRepr ptr = unsafeRunPy $ runProgram $ do
+  SomeException err <- progIO $ deRefStablePtr $ castPtrToStablePtr ptr
+  -- We need to make sure that we evaluated string so that we won't
+  -- leak exceptions
+  repr  <- progIO $ evaluate $ force $ show $ typeOf err
+  p_str <- withPyWCString repr
+  progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]
+
+type FunWrapper a = a -> IO (FunPtr a)
+
+foreign import ccall "wrapper" wrapReprFromStablePtr
+  :: FunWrapper (Ptr () -> IO (Ptr PyObject))
+
+
 
 ----------------------------------------------------------------
 -- Running Py monad
@@ -769,46 +801,50 @@ getPyThreadID = PyThreadId <$> [CU.exp| uint64_t { PyThread_get_thread_ident() }
 --   NULL.
 convertHaskell2Py :: SomeException -> Py (Ptr PyObject)
 convertHaskell2Py err = Py $ do
-  withCString ("Haskell exception: "++show err) $ \p_err -> do
-    [C.block| PyObject* {
-      PyErr_SetString(PyExc_RuntimeError, $(char *p_err));
-      return NULL;
-      } |]
+  s_ptr <- newStablePtr err
+  let ptr = castStablePtrToPtr s_ptr
+  [C.block| PyObject* {
+    PyObject* exc = inline_py_HaskellError_create($(void* ptr));
+    PyErr_SetObject(inline_py_HaskellError(), exc);
+    Py_DECREF(exc);
+    return NULL;
+    } |]
 
 -- | Convert python exception to haskell exception. Should only be
 --   called if there's unhandled python exception. Clears exception.
-convertPy2Haskell :: Py PyException
+convertPy2Haskell :: Py SomeException
 convertPy2Haskell = runProgram $ do
   p_errors <- withPyAllocaArray @(Ptr PyObject) 3
-  -- Fetch error indicator
-  (p_type, p_value) <- progIO $ do
-    [CU.block| void {
-       PyObject **p = $(PyObject** p_errors);
-       PyErr_Fetch(p, p+1, p+2);
-       }|]
-    p_type  <- peekElemOff p_errors 0
-    -- NOTE: When we set exception using PyThreadState_SetAsyncExc
-    --       this field remains NULL on python<=3.11. In this case we
-    --       assume it's our AsyncCancelled:
-    p_value <- peekElemOff p_errors 1 >>= \case
-      NULL -> [CU.block| PyObject* {
-        PyObject *err_class = inline_py_AsyncCancelled();
-        PyObject *tuple     = PyTuple_New(0);
-        PyObject *err       = PyObject_Call(err_class, tuple, NULL);
-        Py_DECREF(tuple);
-        return err;
-        } |]
-      p    -> pure p
-    -- Traceback is not used ATM
-    pure (p_type,p_value)
-  -- Convert exception type and value to strings.
+  -- Fetch error information
+  progIO [CU.block| void {
+    PyObject **p = $(PyObject** p_errors);
+    PyErr_Fetch(p, p+1, p+2);
+    }|]
+  -- Fetch exception type.
+  --
+  -- NOTE: When we set exception using PyThreadState_SetAsyncExc this
+  --       field remains NULL on python<=3.11. Thus we must use xdecref
+  p_type  <- progPyBracket $ (Py $ peekElemOff p_errors 0) `bracket` decref
+  p_value <- progPyBracket $ (Py $ peekElemOff p_errors 1) `bracket` xdecref
+  _trace  <- progPyBracket $ (Py $ peekElemOff p_errors 2) `bracket` xdecref
+  -- Should we convert to PyAsyncCancelled?
+  ty_async_cancelled <- progIO [CU.exp| PyObject* { inline_py_AsyncCancelled() } |]
+  when (p_type == ty_async_cancelled) $ do
+    abort $ SomeException PyAsyncCancelled
+  -- Should we convert to haskell exception?
+  ty_hask_err <- progIO [CU.exp| PyObject* { inline_py_HaskellError() } |]
+  when (p_type == ty_hask_err) $ do
+    s_ptr <- progIO [CU.exp| void* { inline_py_HaskellError_get_stableptr($(PyObject* p_value)) } |]
+    err   <- progIO $ deRefStablePtr $ castPtrToStablePtr s_ptr
+    abort err
+  -- Convert any other python exception
   progPy $ do
     s_type  <- pyobjectStrAsHask p_type
     s_value <- pyobjectStrAsHask p_value
     incref p_value
     exc     <- newPyObject p_value
     let bad_str = "__str__ call failed"
-    pure $ PyException
+    pure $ SomeException $ PyError $ PyException
       { ty        = fromMaybe bad_str s_type
       , str       = fromMaybe bad_str s_value
       , exception = exc
@@ -819,15 +855,15 @@ checkThrowPyError :: Py ()
 checkThrowPyError =
   Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case
     NULL -> pure ()
-    _    -> throwM . PyError =<< convertPy2Haskell
+    _    -> throwM =<< convertPy2Haskell
 
 -- | Throw python error as haskell exception if it's raised. If it's
 --   not that internal error. Another exception will be raised
 mustThrowPyError :: Py a
 mustThrowPyError =
   Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case
     NULL -> error $ "mustThrowPyError: no python exception raised."
-    _    -> throwM . PyError =<< convertPy2Haskell
+    _    -> throwM =<< convertPy2Haskell
 
 -- | Calls mustThrowPyError if pointer is null or returns it unchanged
 throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject)

src/Python/Internal/Program.hs

@@ -6,6 +6,7 @@ module Python.Internal.Program
   , runProgram
   , progPy
   , progIO
+  , progPyBracket
   , progIOBracket
     -- * Control flow
   , abort
@@ -67,6 +68,9 @@ progPy = Program . lift
 progIOBracket :: ((a -> IO r) -> IO r) -> Program r a
 progIOBracket = coerce
 
+progPyBracket :: ((a -> Py r) -> Py r) -> Program r a
+progPyBracket = coerce
+
 -- | Early exit from continuation monad.
 abort :: r -> Program r a
 abort r = Program $ ContT $ \_ -> pure r