Implement proper interruption of runPyAsync

cbits/python.c

@@ -221,3 +221,35 @@ PyObject* inline_py_AsyncError() {
     }
     return AsyncError;
 }
+
+
+static Py_tss_t key_py_async = Py_tss_NEEDS_INIT;
+
+void inline_py_init_state(void *stack) {
+    int r = PyThread_tss_set(&key_py_async, stack);
+    if( 0 != r ) {
+        fprintf(stderr, "inline-python: fatal error: setting thread local storage failed\n");
+        exit(1);
+    }
+}
+
+void inline_py_free_state(void) {
+    int r = PyThread_tss_set(&key_py_async, NULL);
+    if( 0 != r ) {
+        fprintf(stderr, "inline-python: fatal error: setting thread local storage failed\n");
+        exit(1);
+    }
+}
+
+void* inline_py_get_state(void) {
+    return PyThread_tss_get(&key_py_async);
+}
+
+
+void inline_py_initialize(void) {
+    int r = PyThread_tss_create(&key_py_async);
+    if( 0 != r ) {
+        fprintf(stderr, "inline-python: fatal error: Failed to initialized thread local storage\n");
+        exit(1);
+    }
+}

include/inline-python.h

@@ -17,6 +17,8 @@ typedef _PyCFunctionFast PyCFunctionFast;
 #define Py_IsFinalizing(x) 0
 #endif
 
+// General initialization of internal on C side
+void inline_py_initialize(void);
 
 
 // ================================================================
@@ -85,8 +87,19 @@ void inline_py_Integer_FromPy(
 
 
 // ================================================================
-// Async exceptions
+// runPyAsync & Async exceptions
 // ================================================================
 
+// Initialize thread local storage as used by runPyAsync
+void inline_py_init_state(void *stack);
+
+// Delete thread local storage used by runPyAsync
+void inline_py_free_state(void);
+
+// Return stable pointer to stack from TLS
+void* inline_py_get_state(void);
+
+
+
 // Obtain class for async exception
 PyObject* inline_py_AsyncError();

src/Python/Inline/Literal.hs

@@ -14,6 +14,8 @@ module Python.Inline.Literal
   , fromPy'
   ) where
 
+import Control.Concurrent
+import Control.Concurrent.STM
 import Control.Exception           (evaluate)
 import Control.Monad
 import Control.Monad.Catch
@@ -44,6 +46,7 @@ import Numeric.Natural             (Natural)
 import Foreign.Ptr
 import Foreign.C.Types
 import Foreign.Storable
+import Foreign.StablePtr
 import Foreign.Marshal.Alloc     (alloca,mallocBytes)
 import Foreign.Marshal.Utils     (copyBytes)
 import GHC.Float                 (float2Double, double2Float)
@@ -925,7 +928,27 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> Py b) where
 
 -- | Execute haskell callback function
 pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
-pyCallback io = callbackEnsurePyLock $ unsafeRunPy $ ensureGIL $ runProgram io `catch` convertHaskell2Py
+pyCallback io
+  = mask_
+  $ withCallbackStack
+  $ unsafeRunPy
+  $ ensureGIL
+  $ runProgram io `catch` convertHaskell2Py
+
+withCallbackStack :: IO a -> IO a
+withCallbackStack = bracket ini fini . const where
+  ini = [CU.exp| void* { inline_py_get_state() } |] >>= \case
+    NULL -> return NULL
+    ptr  -> do
+      tid   <- myThreadId
+      stack <- deRefStablePtr $ castPtrToStablePtr ptr
+      atomically $ modifyTVar' stack (tid:)
+      return ptr
+  fini NULL = return ()
+  fini ptr  = do
+    stack <- deRefStablePtr $ castPtrToStablePtr ptr
+    atomically $ modifyTVar' stack (drop 1)
+
 
 -- | Load argument from python object for haskell evaluation
 loadArg