diff --git a/include/inline-python.h b/include/inline-python.h index 28fa2aa..1f5efcc 100644 --- a/include/inline-python.h +++ b/include/inline-python.h @@ -5,18 +5,11 @@ #include -// 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 - // ================================================================ diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index e60ef75..dff3515 100644 --- a/src/Python/Inline/Literal.hs +++ b/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 } |] diff --git a/src/Python/Inline/QQ.hs b/src/Python/Inline/QQ.hs index fe5ed75..dc49815 100644 --- a/src/Python/Inline/QQ.hs +++ b/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" diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs index 65b82be..65e74f5 100644 --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -15,6 +15,7 @@ module Python.Internal.Eval -- * PyObject wrapper , newPyObject , decref + , incref , takeOwnership , ensureGIL , dropGIL @@ -22,7 +23,10 @@ module Python.Internal.Eval , convertHaskell2Py , convertPy2Haskell , throwPyError + , mustThrowPyError , throwPyConvesionFailed + -- * Debugging + , debugPrintPy ) where import Control.Concurrent @@ -91,6 +95,9 @@ C.include "" -- 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)) ); + } |] diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs index dff2988..a26f803 100644 --- a/src/Python/Internal/EvalQQ.hs +++ b/src/Python/Internal/EvalQQ.hs @@ -3,15 +3,15 @@ -- | module Python.Internal.EvalQQ ( -- * Evaluators and QQ - pyEvalInMain + pyExecExpr , pyEvalExpr + , evaluatorPymain + , evaluatorPy_ + , evaluatorPye + , evaluatorPyf + -- * Code generation , expQQ - , basicNewDict - , basicMainDict - , basicBindInDict - , basicDecref - -- * Python transformations - , unindent + , Mode(..) ) where import Control.Monad.IO.Class @@ -19,12 +19,12 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Cont import Data.Bits import Data.Char +import Data.List (intercalate) import Data.ByteString qualified as BS import Data.Text qualified as T import Data.Text.Encoding qualified as T import Foreign.C.Types import Foreign.Ptr -import Foreign.Storable import System.Exit import System.Process (readProcessWithExitCode) @@ -51,88 +51,105 @@ C.include "" -- | Evaluate expression within context of @__main__@ module. All -- variables defined in this evaluator persist. -pyEvalInMain +pyExecExpr :: Ptr PyObject -- ^ Globals -> Ptr PyObject -- ^ Locals - -> String + -> String -- ^ Python source code -> Py () -pyEvalInMain p_globals p_locals src = evalContT $ do - p_py <- withPyCString src - r <- liftIO [C.block| int { - PyObject *code = Py_CompileString($(char* p_py), "", Py_file_input); - if( PyErr_Occurred() ){ - return IPY_ERR_COMPILE; - } - // Execute in context of main - PyObject* globals = $(PyObject* p_globals); - PyObject* locals = $(PyObject* p_locals); - PyObject* r = PyEval_EvalCode(code, globals, locals); - Py_XDECREF(r); - if( PyErr_Occurred() ) { - return IPY_ERR_PYTHON; - } - return IPY_OK; - } |] - lift $ finiEval r (pure ()) +pyExecExpr p_globals p_locals src = evalContT $ do + p_py <- withPyCString src + lift $ do + Py [C.block| void { + PyObject* globals = $(PyObject* p_globals); + PyObject* locals = $(PyObject* p_locals); + // Compile code + PyObject *code = Py_CompileString($(char* p_py), "", Py_file_input); + if( PyErr_Occurred() ){ + return; + } + // Execute statements + PyObject* res = PyEval_EvalCode(code, globals, locals); + Py_XDECREF(res); + Py_DECREF(code); + } |] + throwPyError -- | Evaluate expression with fresh local environment pyEvalExpr - :: Ptr PyObject -- ^ Dictionary with local + :: Ptr PyObject -- ^ Globals + -> Ptr PyObject -- ^ Locals -> String -- ^ Python source code -> Py PyObject -pyEvalExpr p_env src = evalContT $ do +pyEvalExpr p_globals p_locals src = evalContT $ do p_py <- withPyCString src - p_res <- withPyAlloca @(Ptr PyObject) - r <- liftIO [C.block| int { - // Compile code - PyObject *code = Py_CompileString($(char* p_py), "", Py_eval_input); - if( PyErr_Occurred() ) { - return IPY_ERR_COMPILE; - } - // Execute in context of main - PyObject* main_module = PyImport_AddModule("__main__"); - if( PyErr_Occurred() ) { - return IPY_ERR_PYTHON; - } - PyObject* globals = PyModule_GetDict(main_module); - if( PyErr_Occurred() ) { - return IPY_ERR_PYTHON; - } - // - PyObject* r = PyEval_EvalCode(code, globals, $(PyObject* p_env)); - if( PyErr_Occurred() ) { - return IPY_ERR_PYTHON; - } - Py_INCREF(r); - *$(PyObject **p_res) = r; - return IPY_OK; - }|] - lift $ finiEval r (newPyObject =<< liftIO (peek p_res)) - --- | Convert evaluation result and -finiEval - :: CInt - -> Py a - -> Py a -finiEval r fini = case r of - IPY_OK -> fini - IPY_ERR_COMPILE -> throwPy =<< convertPy2Haskell - IPY_ERR_PYTHON -> throwPy =<< convertPy2Haskell - _ -> error $ "pyEvalStr: unexpected error: " ++ show r + lift $ do + p_res <- Py [C.block| PyObject* { + PyObject* globals = $(PyObject* p_globals); + PyObject* locals = $(PyObject* p_locals); + // Compile code + PyObject *code = Py_CompileString($(char* p_py), "", Py_eval_input); + if( PyErr_Occurred() ) { + return NULL; + } + // Evaluate expression + PyObject* r = PyEval_EvalCode(code, globals, locals); + Py_DECREF(code); + return r; + }|] + throwPyError + newPyObject p_res + + +evaluatorPymain :: (Ptr PyObject -> Py String) -> Py () +evaluatorPymain getSource = do + p_main <- basicMainDict + src <- getSource p_main + pyExecExpr p_main p_main src + +evaluatorPy_ :: (Ptr PyObject -> Py String) -> Py () +evaluatorPy_ getSource = evalContT $ do + p_globals <- lift basicMainDict + p_locals <- takeOwnership =<< lift basicNewDict + lift $ pyExecExpr p_globals p_locals =<< getSource p_locals + +evaluatorPye :: (Ptr PyObject -> Py String) -> Py PyObject +evaluatorPye getSource = evalContT $ do + p_globals <- lift basicMainDict + p_locals <- takeOwnership =<< lift basicNewDict + lift $ pyEvalExpr p_globals p_locals =<< getSource p_locals + +evaluatorPyf :: (Ptr PyObject -> Py String) -> Py PyObject +evaluatorPyf getSource = evalContT $ do + p_globals <- lift basicMainDict + p_locals <- takeOwnership =<< lift basicNewDict + p_kwargs <- takeOwnership =<< lift basicNewDict + lift $ do + -- Create function in p_locals + pyExecExpr p_globals p_locals =<< getSource p_kwargs + -- Look up function + p_fun <- getFunctionObject p_locals >>= \case + NULL -> error "INTERNAL ERROR: _inline_python_ must be present" + p -> pure p + -- Call python function we just constructed + callFunctionObject p_fun p_kwargs >>= \case + NULL -> mustThrowPyError "evaluatorPyf" + p_res -> newPyObject p_res + basicBindInDict :: ToPy a => String -> a -> Ptr PyObject -> Py () basicBindInDict name a p_dict = evalContT $ do - -- FIXME: error handling - -- FIXME: meanining of errors in PyUnicode_DecodeUTF8? - (p_key,len) <- withPyCStringLen name - p_obj <- lift $ basicToPy a - let c_len = fromIntegral len :: CLong - liftIO [C.block| void { - PyObject* p_obj = $(PyObject* p_obj); - PyObject* key = PyUnicode_DecodeUTF8( $(char* p_key), $(long c_len), 0); - PyDict_SetItem($(PyObject* p_dict), key, p_obj); - Py_DECREF(p_obj); - } |] + (p_key) <- withPyCString name + p_obj <- takeOwnership =<< lift (basicToPy a) + lift $ case p_obj of + NULL -> mustThrowPyError "basicBindInDict" + _ -> do + r <- Py [C.block| int { + PyObject* p_obj = $(PyObject* p_obj); + return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); + } |] + case r of + 0 -> pure () + _ -> mustThrowPyError "basicBindInDict" basicNewDict :: Py (Ptr PyObject) basicNewDict = Py [CU.exp| PyObject* { PyDict_New() } |] @@ -141,11 +158,21 @@ basicNewDict = Py [CU.exp| PyObject* { PyDict_New() } |] basicMainDict :: Py (Ptr PyObject) basicMainDict = Py [CU.block| PyObject* { PyObject* main_module = PyImport_AddModule("__main__"); + if( PyErr_Occurred() ) + return NULL; return PyModule_GetDict(main_module); }|] -basicDecref :: Ptr PyObject -> Py () -basicDecref o = Py [CU.exp| void { Py_DECREF($(PyObject* o)) } |] +getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject) +getFunctionObject p_dict = do + Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |] + +callFunctionObject :: Ptr PyObject -> Ptr PyObject -> Py (Ptr PyObject) +callFunctionObject fun kwargs = Py [CU.block| PyObject* { + PyObject* args = PyTuple_Pack(0); + return PyObject_Call($(PyObject *fun), args, $(PyObject *kwargs)); + } |] + ---------------------------------------------------------------- @@ -158,23 +185,36 @@ script = $( do let path = "py/bound-vars.py" TH.lift =<< TH.runIO (readFile path) ) +data Mode + = Eval + | Exec + | Fun + -- | Generate TH splice which updates python environment dictionary -- and returns python source code. -expQQ :: String -- ^ Python evaluation mode: @exec@/@eval@ +expQQ :: Mode -- ^ Python evaluation mode: @exec@/@eval@ -> String -- ^ Python source code -> TH.Q TH.Exp -expQQ mode src = do +expQQ mode qq_src = do + -- We need to preprocess before passing it to python. + let src = prepareSource mode qq_src + src_var = prepareForVarLookup mode src antis <- liftIO $ do -- We've embedded script into library and we need to pass source -- code of QQ to a script. It can contain whatever symbols so to -- be safe it's base16 encode. This encoding is very simple and we -- don't care much about efficiency here - (code, stdout, stderr) <- readProcessWithExitCode "python" ["-", mode] + (code, stdout, stderr) <- readProcessWithExitCode "python" + [ "-" + , case mode of Eval -> "eval" + Exec -> "exec" + Fun -> "exec" + ] $ unlines [ script , "decode_and_print('" <> concat [ [ intToDigit $ fromIntegral (w `shiftR` 4) , intToDigit $ fromIntegral (w .&. 15) ] - | w <- BS.unpack $ T.encodeUtf8 $ T.pack src + | w <- BS.unpack $ T.encodeUtf8 $ T.pack src_var ] <> "')" ] @@ -184,10 +224,11 @@ expQQ mode src = do let args = [ [| basicBindInDict $(TH.lift nm) $(TH.dyn (chop nm)) |] | nm <- antis ] + src_eval = prepareForEval mode antis src -- [| \p_dict -> do mapM_ ($ p_dict) $(TH.listE args) - pure $(TH.lift src) + pure $(TH.lift src_eval) |] @@ -203,10 +244,45 @@ chop name = take (length name - length antiSuffix) name -- Python source code transform ---------------------------------------------------------------- -unindent :: String -> String -unindent py = case ls of - [] -> "" - _ -> unlines $ drop n <$> ls +prepareSource :: Mode -> String -> String +prepareSource = \case + Eval -> dropWhile isSpace + Exec -> unindent + Fun -> unindent + +prepareForVarLookup :: Mode -> String -> String +prepareForVarLookup = \case + Eval -> id + Exec -> id + Fun -> ("def __dummy__():\n"++) . indent + +prepareForEval :: Mode -> [String] -> String -> String +prepareForEval mode vars src = case mode of + Eval -> src + Exec -> src + Fun -> "def _inline_python_("<>args<>"):\n" + <> indent src where - n = minimum [ length (takeWhile (==' ') s) | s <- ls ] - ls = filter (any (not . isSpace)) $ lines py + args = intercalate "," vars + +-- Python is indentation based and quasiquotes do not strip leading +-- space. We have to do that ourself +unindent :: String -> String +unindent py_src = case lines py_src of + [] -> "" + -- Strip all leading space for 1-line scripts + [l] -> dropWhile isSpace l + -- For multiline script we require that first line should be empty + l:ls + | any (not . isSpace) l -> error "First line of multiline quasiquote must be empty" + -- FIXME: We break multiline strings here. Badly. We need proper python lexer + -- FIXME: We probably should just forbid tabs + | otherwise -> + let non_empty = filter (any (not . isSpace)) ls + n = minimum [ length (takeWhile (==' ') s) | s <- non_empty ] + in unlines $ drop n <$> ls + +indent :: String -> String +indent = unlines + . map (" "++) + . lines diff --git a/test/TST/Run.hs b/test/TST/Run.hs index b66fc52..419fc32 100644 --- a/test/TST/Run.hs +++ b/test/TST/Run.hs @@ -81,4 +81,26 @@ tests = testGroup "Run python" except NameError: pass |] + , testCase "Scope pyf->any" $ do + _ <- [pyf| + x = 12 + x + return 12 + |] + -- Not visible + throwsPy $ void [pye| x |] + [py_| + try: + x + assert False, "x shouln't be visible (1)" + except NameError: + pass + |] + [pymain| + try: + x + assert False, "x shouln't be visible (2)" + except NameError: + pass + |] ]