Release GIL when calling back into C

cbits/python.c

@@ -11,10 +11,10 @@
 // reacquire GIL there.
 // ================================================================
 
-static PyObject* callback_METH_O(PyObject* self, PyObject* arg) {
+// Same wrapper works for METH_O and METH_NOARGS
+static PyObject* callback_METH_CFunction(PyObject* self, PyObject* arg) {
     PyObject    *res;
     PyCFunction *fun = PyCapsule_GetPointer(self, NULL);
-    //--
 Py_BEGIN_ALLOW_THREADS
     res = (*fun)(self, arg);
 Py_END_ALLOW_THREADS
@@ -24,7 +24,6 @@ Py_END_ALLOW_THREADS
 static PyObject* callback_METH_FASTCALL(PyObject* self, PyObject** args, Py_ssize_t nargs) {
     PyObject        *res;
     PyCFunctionFast *fun = PyCapsule_GetPointer(self, NULL);
-    //--
 Py_BEGIN_ALLOW_THREADS
     res = (*fun)(self, args, nargs);
 Py_END_ALLOW_THREADS
@@ -39,9 +38,16 @@ static void capsule_free_FunPtr(PyObject* capsule) {
     free(fun);
 }
 
+static PyMethodDef method_METH_NOARGS = {
+    .ml_name  = "[inline_python]",
+    .ml_meth  = callback_METH_CFunction,
+    .ml_flags = METH_NOARGS,
+    .ml_doc   = "Wrapper for haskell callback"
+};
+
 static PyMethodDef method_METH_O = {
     .ml_name  = "[inline_python]",
-    .ml_meth  = callback_METH_O,
+    .ml_meth  = callback_METH_CFunction,
     .ml_flags = METH_O,
     .ml_doc   = "Wrapper for haskell callback"
 };
@@ -53,6 +59,18 @@ static PyMethodDef method_METH_FASTCALL = {
     .ml_doc   = "Wrapper for haskell callback"
 };
 
+PyObject *inline_py_callback_METH_NOARGS(PyCFunction fun) {
+    PyCFunction *buf = malloc(sizeof(PyCFunction));
+    *buf = fun;
+    PyObject* self = PyCapsule_New(buf, NULL, &capsule_free_FunPtr);
+    if( PyErr_Occurred() )
+        return NULL;
+    // Python function
+    PyObject* f = PyCFunction_New(&method_METH_NOARGS, self);
+    Py_DECREF(self);
+    return f;
+}
+
 PyObject *inline_py_callback_METH_O(PyCFunction fun) {
     PyCFunction *buf = malloc(sizeof(PyCFunction));
     *buf = fun;

include/inline-python.h

@@ -23,6 +23,9 @@ typedef _PyCFunctionFast PyCFunctionFast;
 // Callbacks
 // ================================================================
 
+// Wrap haskell callback using METH_NOARGS calling convention
+PyObject *inline_py_callback_METH_NOARGS(PyCFunction fun);
+
 // Wrap haskell callback using METH_O calling convention
 PyObject *inline_py_callback_METH_O(PyCFunction fun);
 

src/Python/Inline/Literal.hs

@@ -116,6 +116,9 @@ instance FromPy PyObject where
     Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]
     newPyObject p
 
+instance ToPy () where
+  basicToPy () = Py [CU.exp| PyObject* { Py_None } |]
+
 instance ToPy CLong where
   basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLong($(long i)) } |]
 instance FromPy CLong where
@@ -352,26 +355,35 @@ instance (FromPy a) => FromPy [a] where
 --        with async exception out of the blue
 
 
+instance (ToPy b) => ToPy (IO b) where
+  basicToPy f = Py $ do
+    --
+    f_ptr <- wrapCFunction $ \_ _ -> pyCallback $ do
+      lift $ basicToPy =<< dropGIL f
+    --
+    [CU.exp| PyObject* { inline_py_callback_METH_NOARGS($(PyCFunction f_ptr)) } |]
+
+
 instance (FromPy a, Show a, ToPy b) => ToPy (a -> IO b) where
   basicToPy f = Py $ do
-    -- C function pointer for callback
-    f_ptr <- wrapO $ \_ p_a -> pyCallback $ do
+    --
+    f_ptr <- wrapCFunction $ \_ p_a -> pyCallback $ do
       a <- loadArg p_a 0 1
-      liftIO $ unPy . basicToPy =<< f a
+      lift $ basicToPy =<< dropGIL (f a)
     --
     [CU.exp| PyObject* { inline_py_callback_METH_O($(PyCFunction f_ptr)) } |]
 
 
 instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
   basicToPy f = Py $ do
-    -- Create haskell function
+    --
     f_ptr <- wrapFastcall $ \_ p_arr n -> pyCallback $ do
       when (n /= 2) $ abortM $ raiseBadNArgs 2 n
-      a <- loadArgFastcall p_arr 0 n
-      b <- loadArgFastcall p_arr 1 n
-      liftIO $ unPy . basicToPy =<< f a b
-    -- Create python function
-    [C.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |]
+      a1 <- loadArgFastcall p_arr 0 n
+      a2 <- loadArgFastcall p_arr 1 n
+      lift $ basicToPy =<< dropGIL (f a1 a2)
+    --
+    [CU.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |]
 
 ----------------------------------------------------------------
 -- Helpers
@@ -423,7 +435,7 @@ raiseBadNArgs expected got = Py [CU.block| PyObject* {
 
 type FunWrapper a = a -> IO (FunPtr a)
 
-foreign import ccall "wrapper" wrapO
+foreign import ccall "wrapper" wrapCFunction
   :: FunWrapper (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject))
 
 foreign import ccall "wrapper" wrapFastcall

src/Python/Internal/Eval.hs

@@ -17,6 +17,7 @@ module Python.Internal.Eval
   , decref
   , takeOwnership
   , ensureGIL
+  , dropGIL
     -- * Exceptions
   , convertHaskell2Py
   , convertPy2Haskell
@@ -242,6 +243,15 @@ ensureGIL action = do
   gil_state <- Py [CU.exp| int { PyGILState_Ensure() } |]
   action `finallyPy` Py [CU.exp| void { PyGILState_Release($(int gil_state)) } |]
 
+-- | Drop GIL temporarily
+dropGIL :: IO a -> Py a
+dropGIL action = do
+  -- NOTE: We're cheating here and looking behind the veil.
+  --       PyGILState_STATE is defined as enum. Let hope it will stay
+  --       this way.
+  st <- Py [CU.exp| PyThreadState* { PyEval_SaveThread() } |]
+  Py $ action `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |]
+
 -- | Decrement reference counter at end of ContT block
 takeOwnership :: Ptr PyObject -> Program r (Ptr PyObject)
 takeOwnership p = ContT $ \c -> c p `finallyPy` decref p

src/Python/Internal/Types.hs

@@ -9,6 +9,7 @@ module Python.Internal.Types
   ( -- * Data type
     PyObject(..)
   , unsafeWithPyObject
+  , PyThreadState
   , PyError(..)
   , Py(..)
   , catchPy
@@ -42,6 +43,9 @@ import Language.C.Inline.Context
 -- Primitives
 ----------------------------------------------------------------
 
+-- | Pointer tag
+data PyThreadState
+
 -- | Some python object. Since almost everything in python is mutable
 --   it could only be accessed only in IO monad.
 newtype PyObject = PyObject (ForeignPtr PyObject)
@@ -97,8 +101,8 @@ tryPy = coerce (try @e @a)
 pyCtx :: Context
 pyCtx = mempty { ctxTypesTable = Map.fromList tytabs } where
   tytabs =
-    [ ( TypeName "PyObject"
-      , [t| PyObject |])
+    [ ( TypeName "PyObject",      [t| PyObject      |])
+    , ( TypeName "PyThreadState", [t| PyThreadState |])
     , ( TypeName "PyCFunction"
       , [t| FunPtr (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject)) |])
     , ( TypeName "PyCFunctionFast"

test/TST/Callbacks.hs

@@ -10,7 +10,18 @@ import TST.Util
 
 tests :: TestTree
 tests = testGroup "Callbacks"
-  [ testCase "Function(arity=1)" $ do
+  [ testCase "Function(arity 0)" $ do
+      let double = pure 2 :: IO Int
+      [py_|
+         # OK
+         assert double_hs() == 2
+         # Wrong arg number
+         try:
+             double_hs(1,2,3)
+         except TypeError as e:
+             pass
+         |]
+  , testCase "Function(arity=1)" $ do
       let double = pure . (*2) :: Int -> IO Int
       [py_|
          # OK