diff --git a/cbits/python.c b/cbits/python.c index 8ece0ef..2113f49 100644 --- a/cbits/python.c +++ b/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; diff --git a/include/inline-python.h b/include/inline-python.h index b9041f8..28fa2aa 100644 --- a/include/inline-python.h +++ b/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); diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index 000d19e..e60ef75 100644 --- a/src/Python/Inline/Literal.hs +++ b/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 diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs index 21210cc..12a394a 100644 --- a/src/Python/Internal/Eval.hs +++ b/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 diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs index 056f604..2ee84b1 100644 --- a/src/Python/Internal/Types.hs +++ b/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" diff --git a/test/TST/Callbacks.hs b/test/TST/Callbacks.hs index 5e8900c..649bed4 100644 --- a/test/TST/Callbacks.hs +++ b/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