Merge pull request #14 from Shimuuar/new-QQ-pyf

New quasiquoter pyf and number of memory-related bugs

Author: Shimuuar

include/inline-python.h

@@ -5,18 +5,11 @@
 #include <Rts.h>
 
 
-// Use new stable API from 
+// Use new stable API from 3.13
 #ifndef PyCFunctionFast
 typedef _PyCFunctionFast PyCFunctionFast;
 #endif
 
-// ----------------------------------------------------------------
-// Standard status codes
-
-#define IPY_OK          0
-#define IPY_ERR_PYTHON  1
-#define IPY_ERR_COMPILE 2
-
 
 
 // ================================================================

src/Python/Inline/Literal.hs

@@ -109,12 +109,9 @@ toPy a = runPy $ basicToPy a >>= \case
 ----------------------------------------------------------------
 
 instance ToPy PyObject where
-  basicToPy o = unsafeWithPyObject o $ \p ->
-    p <$ Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]
+  basicToPy o = unsafeWithPyObject o $ \p -> p <$ incref p
 instance FromPy PyObject where
-  basicFromPy p = do
-    Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]
-    newPyObject p
+  basicFromPy p = incref p >> newPyObject p
 
 instance ToPy () where
   basicToPy () = Py [CU.exp| PyObject* { Py_None } |]

src/Python/Inline/QQ.hs

@@ -7,6 +7,7 @@ module Python.Inline.QQ
   ( pymain
   , py_
   , pye
+  , pyf
   ) where
 
 import Language.Haskell.TH.Quote
@@ -22,10 +23,7 @@ import Python.Internal.Eval
 --   This quote creates object of type @IO ()@
 pymain :: QuasiQuoter
 pymain = QuasiQuoter
-  { quoteExp  = \txt -> [| runPy $ do p_main <- basicMainDict
-                                      src   <- $(expQQ "exec" (unindent txt)) p_main
-                                      pyEvalInMain p_main p_main src
-                         |]
+  { quoteExp  = \txt -> [| runPy $ evaluatorPymain $(expQQ Exec txt) |]
   , quotePat  = error "quotePat"
   , quoteType = error "quoteType"
   , quoteDec  = error "quoteDec"
@@ -38,13 +36,7 @@ pymain = QuasiQuoter
 --   This quote creates object of type @IO ()@
 py_ :: QuasiQuoter
 py_ = QuasiQuoter
-  { quoteExp  = \txt -> [| runPy $ do p_globals <- basicMainDict
-                                      p_locals  <- basicNewDict
-                                      src   <- $(expQQ "exec" (unindent txt)) p_locals
-                                      res   <- pyEvalInMain p_globals p_locals src
-                                      basicDecref p_locals
-                                      return res
-                         |]
+  { quoteExp  = \txt -> [| runPy $ evaluatorPy_ $(expQQ Exec txt) |]
   , quotePat  = error "quotePat"
   , quoteType = error "quoteType"
   , quoteDec  = error "quoteDec"
@@ -56,12 +48,19 @@ py_ = QuasiQuoter
 --   This quote creates object of type @IO PyObject@
 pye :: QuasiQuoter
 pye = QuasiQuoter
-  { quoteExp  = \txt -> [| runPy $ do p_env <- basicNewDict
-                                      src   <- $(expQQ "eval" (unindent txt)) p_env
-                                      res   <- pyEvalExpr p_env src
-                                      basicDecref p_env
-                                      return res
-                         |]
+  { quoteExp  = \txt -> [| runPy $ evaluatorPye $(expQQ Eval txt) |]
+  , quotePat  = error "quotePat"
+  , quoteType = error "quoteType"
+  , quoteDec  = error "quoteDec"
+  }
+
+-- | Another quasiquoter which works around that sequence of python
+--   statements doesn't have any value associated with it.  Content of
+--   quasiquote is function body. So to get value out of it one must
+--   call return
+pyf :: QuasiQuoter
+pyf = QuasiQuoter
+  { quoteExp  = \txt -> [| runPy $ evaluatorPyf $(expQQ Fun txt) |]
   , quotePat  = error "quotePat"
   , quoteType = error "quoteType"
   , quoteDec  = error "quoteDec"

src/Python/Internal/Eval.hs

@@ -15,14 +15,18 @@ module Python.Internal.Eval
     -- * PyObject wrapper
   , newPyObject
   , decref
+  , incref
   , takeOwnership
   , ensureGIL
   , dropGIL
     -- * Exceptions
   , convertHaskell2Py
   , convertPy2Haskell
   , throwPyError
+  , mustThrowPyError
   , throwPyConvesionFailed
+    -- * Debugging
+  , debugPrintPy
   ) where
 
 import Control.Concurrent
@@ -91,6 +95,9 @@ C.include "<inline-python.h>"
 --  2. Overhead of `runInBoundThread` is significant for GC (~1μs)
 --     will this cause problem or if there're only few object on
 --     haskell heap it would be fine?
+--
+-- In addition we must not do anything after interpreter shutdown.
+-- It already released memory. Most of it at least.
 
 
 
@@ -241,6 +248,9 @@ doFinalizePython = [C.block| void {
 decref :: Ptr PyObject -> Py ()
 decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |]
 
+incref :: Ptr PyObject -> Py ()
+incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]
+
 -- | Ensure that we hold GIL for duration of action
 ensureGIL :: Py a -> Py a
 ensureGIL action = do
@@ -266,19 +276,16 @@ takeOwnership p = ContT $ \c -> c p `finallyPy` decref p
 
 -- | Wrap raw python object into
 newPyObject :: Ptr PyObject -> Py PyObject
--- We need to use different implementation for different RTS
 -- See NOTE: [GC]
-newPyObject p
-  | rtsSupportsBoundThreads = Py $ do
-      fptr <- newForeignPtr_ p
-      GHC.addForeignPtrFinalizer fptr $ runInBoundThread $ unPy $ decref p
-      pure $ PyObject fptr
-  | otherwise = Py $ do
-      fptr <- newForeignPtr_ p
-      PyObject fptr <$ addForeignPtrFinalizer py_XDECREF fptr
-
-py_XDECREF :: FunPtr (Ptr PyObject -> IO ())
-py_XDECREF = [C.funPtr| void inline_py_XDECREF(PyObject* p) { Py_XDECREF(p); } |]
+newPyObject p = Py $ do
+  fptr <- newForeignPtr_ p
+  -- FIXME: We still have race between check and interpreter
+  --        shutdown. At least it's narrow race
+  GHC.addForeignPtrFinalizer fptr $ do
+    [CU.exp| int { Py_IsInitialized() } |] >>= \case
+        0 -> pure ()
+        _ -> runPy $ decref p
+  pure $ PyObject fptr
 
 
 
@@ -348,6 +355,14 @@ throwPyError =
     NULL -> pure ()
     _    -> throwPy =<< convertPy2Haskell
 
+-- | Throw python error as haskell exception if it's raised. If it's
+--   not that internal error. Another exception will be raised
+mustThrowPyError :: String -> Py a
+mustThrowPyError msg =
+  Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case
+    NULL -> error $ "mustThrowPyError: no python exception raised. " ++ msg
+    _    -> throwPy =<< convertPy2Haskell
+
 throwPyConvesionFailed :: Py ()
 throwPyConvesionFailed = do
   r <- Py [CU.block| int {
@@ -360,3 +375,14 @@ throwPyConvesionFailed = do
   case r of
     0 -> pure ()
     _ -> throwPy FromPyFailed
+
+
+----------------------------------------------------------------
+-- Debugging
+----------------------------------------------------------------
+
+debugPrintPy :: Ptr PyObject -> Py ()
+debugPrintPy p = Py [CU.block| void {
+  PyObject_Print($(PyObject *p), stdout, 0);
+  printf(" [REF=%li]\n", Py_REFCNT($(PyObject *p)) );
+  } |]