{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE QuasiQuotes               #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE TemplateHaskell           #-}
-- |
-- Evaluation of python expressions.
module Python.Internal.Eval
  ( -- * Locks
    ensurePyLock
  , callbackEnsurePyLock
    -- * Initialization
  , initializePython
  , finalizePython
  , withPython
    -- * Evaluator
  , runPy
  , runPyInMain
  , unsafeRunPy
    -- * GC-related
  , newPyObject
    -- * C-API wrappers
  , takeOwnership
  , ensureGIL
  , dropGIL
    -- * Exceptions
  , convertHaskell2Py
  , convertPy2Haskell
  , checkThrowPyError
  , mustThrowPyError
  , checkThrowBadPyType
  , throwOnNULL
    -- * Exec & eval
  , Namespace(..)
  , Main(..)
  , Temp(..)
  , Dict(..)
  , DictPtr(..)
  , Module(..)
  , ModulePtr(..)
  , unsafeWithCode
  , eval
  , exec
    -- * Debugging
  , debugPrintPy
  ) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception         (interruptible)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Data.Maybe
import Data.Function
import Data.ByteString.Unsafe    qualified as BS
import Foreign.Concurrent        qualified as GHC
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.Storable
import System.Environment
import System.IO.Unsafe

import Language.C.Inline          qualified as C
import Language.C.Inline.Unsafe   qualified as CU

import Python.Internal.CAPI
import Python.Internal.Types
import Python.Internal.Util
import Python.Internal.Program


----------------------------------------------------------------
C.context (C.baseCtx <> pyCtx)
C.include "<inline-python.h>"
----------------------------------------------------------------

-- NOTE: [Python and threading]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Python (cpython to be precise) support threading to and it
-- interacts with haskell threading in interesting and generally
-- unpleasant ways. In short python's threads are:
--
--  1. OS threads. Python is designed to be embeddable and can
--     live with threads scheduled by outside python's runtime.
--
--  2. Any OS thread interacting with python interpreter must hold
--     global interpreter lock (GIL).
--
--  3. GIL uses thread local state.
--
-- Haskell has two runtimes. Single threaded one doesn't cause any
-- troubles and won't be discussed further. Multithreaded one
-- implement N-M threading and schedules N green thread on M OS
-- threads as it see fit.
--
-- One could think that running python code in bound threads and
-- making sure that GIL is held would suffice. It doesn't. Doing so
-- would quickly results in deadlock. Exact reason for that is not
-- understood.
--
-- Another problem is GHC may schedule two threads each running python
-- code on same capability. They won't have any problems taking GIL
-- and will run concurrently stepping on each other's toes.
--
-- Only way to solve this problem is to introduce another lock on
-- haskell side. It's visible to haskell RTS so we won't get deadlocks
-- and it makes sure that only one haskell thread interacts with
-- python at a time.
--
--
--
-- Also python designate thread in which python interpreter was
-- initialized as a main thread. It has special status for example
-- some libraries may run only in main thread (e.g. tkinter). But if
-- we don't take special precautions we won't know which thread it
-- is.
--
--
--
-- There's of course question how well python threading interacts with
-- haskell. No one knows, probably it won't work well.



-- NOTE: [GC]
-- ~~~~~~~~~~
--
-- CPython uses reference counting which should work very well with
-- ForeignPtr. But there's a catch: decrementing counter is only
-- possible if one holds GIL. Taking GIL may block and doing so during
-- GC may eventually will block GC thread and the whole program.
--
-- Current solution is not quite satisfactory: finalizer writes
-- pointer to `Chan` which delivers it to thread which decrements
-- counter. It's not very good solution since we need to take locks
-- for each DECREF which is relatively costly (O(1μs)). But better
-- solutions are not obvious.
--
-- Problem above is only relevant for multithreaded RTS there's no
-- other threads that could hold lock and taking GIL can't fail.



-- NOTE: [Interrupting python]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Being able to interrupt python when haskell exception arrives is
-- surely nice. However it's difficult and comes with tradeoffs.
--
-- First of all call must be done in a separate thread otherwise
-- there's no one to catch exception and to something. This also means
-- that python calls made using plain FFI are not interruptible.
--
-- In addition python's ability to notify other threads are limited:
--
--  + `Py_SetInterrupt` plain doesn't work. It uses signal which trips
--    up haskell RTS as well.
--
--  + `PyThreadState_SetAsyncExc` could be use but it requires special
--    setup from thread being interrupted.



----------------------------------------------------------------
-- Lock and global state
----------------------------------------------------------------

globalPyState :: TVar PyState
globalPyState :: TVar PyState
globalPyState = IO (TVar PyState) -> TVar PyState
forall a. IO a -> a
unsafePerformIO (IO (TVar PyState) -> TVar PyState)
-> IO (TVar PyState) -> TVar PyState
forall a b. (a -> b) -> a -> b
$ PyState -> IO (TVar PyState)
forall a. a -> IO (TVar a)
newTVarIO PyState
NotInitialized
{-# NOINLINE globalPyState #-}

globalPyLock :: TVar PyLock
globalPyLock :: TVar PyLock
globalPyLock = IO (TVar PyLock) -> TVar PyLock
forall a. IO a -> a
unsafePerformIO (IO (TVar PyLock) -> TVar PyLock)
-> IO (TVar PyLock) -> TVar PyLock
forall a b. (a -> b) -> a -> b
$ PyLock -> IO (TVar PyLock)
forall a. a -> IO (TVar a)
newTVarIO PyLock
LockUninialized
{-# NOINLINE globalPyLock #-}


-- | State of python interpreter
data PyState
  = NotInitialized
    -- ^ Initialization is not done. Initial state.
  | InInitialization
    -- ^ Interpreter is being initialized.
  | InitFailed
    -- ^ Initialization was attempted but failed for whatever reason.
  | Running1
    -- ^ Interpreter is running. We're using single threaded RTS
  | RunningN !(Chan (Ptr PyObject))
             !(MVar EvalReq)
             !ThreadId
             !ThreadId
    -- ^ Interpreter is running. We're using multithreaded RTS
  | InFinalization
    -- ^ Interpreter is being finalized.
  | Finalized
    -- ^ Interpreter was shut down.


-- | Lock. It's necessary for lock to reentrant since thread may take
--   it several times for example by nesting 'runPy'. We use
--   'ThreadId' as a key to figure out whether thread may retake lock
--   or not.
--
--   Another special case is callbacks. Callback (via 'FunPtr') will
--   start new haskell thread so we need to add primitive for grabbing
--   lock regardless of current 'ThreadId'
data PyLock
  = LockUninialized
    -- ^ There's no interpreter and lock does not exist.
  | LockUnlocked
    -- ^ Lock could be taked
  | Locked !ThreadId [ThreadId]
    -- ^ Python is locked by given thread. Lock could be taken multiple
    --   times
  | LockedByGC
    -- ^ Python is locked by GC thread.
  | LockFinalized
    -- ^ Python interpreter shut down. Taking lock is not possible
  deriving Int -> PyLock -> ShowS
[PyLock] -> ShowS
PyLock -> String
(Int -> PyLock -> ShowS)
-> (PyLock -> String) -> ([PyLock] -> ShowS) -> Show PyLock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PyLock -> ShowS
showsPrec :: Int -> PyLock -> ShowS
$cshow :: PyLock -> String
show :: PyLock -> String
$cshowList :: [PyLock] -> ShowS
showList :: [PyLock] -> ShowS
Show

-- | Execute code ensuring that python lock is held by current thread.
ensurePyLock :: IO a -> IO a
ensurePyLock :: forall a. IO a -> IO a
ensurePyLock IO a
action = do
  tid <- IO ThreadId
myThreadId
  bracket_ (atomically $ acquireLock tid)
           (atomically $ releaseLock tid)
           action

-- | Retake lock regardless of thread which hold lock. Lock must be
--   already taken. Caller must make sure that thread holding lock is
--   block for duration of action.
--
--   This is very unsafe. It must be used only in callbacks from
--   python to haskell
callbackEnsurePyLock :: IO a -> IO a
callbackEnsurePyLock :: forall a. IO a -> IO a
callbackEnsurePyLock IO a
action = do
  tid <- IO ThreadId
myThreadId
  bracket_ (atomically $ grabLock tid)
           (atomically $ releaseLock tid)
           action


acquireLock :: ThreadId -> STM ()
acquireLock :: ThreadId -> STM ()
acquireLock ThreadId
tid = TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyLock
LockUninialized -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
  PyLock
LockFinalized   -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
  PyLock
LockedByGC      -> STM ()
forall a. STM a
retry
  PyLock
LockUnlocked    -> TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
tid []
  Locked ThreadId
t [ThreadId]
xs
    | ThreadId
t ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid  -> TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
t (ThreadId
t ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
xs)
    | Bool
otherwise -> STM ()
forall a. STM a
retry

grabLock :: ThreadId -> STM ()
grabLock :: ThreadId -> STM ()
grabLock ThreadId
tid = TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyLock
LockUninialized -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
  PyLock
LockFinalized   -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
  PyLock
LockedByGC      -> STM ()
forall a. STM a
retry
  PyLock
LockUnlocked    -> TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
tid []
  Locked ThreadId
t [ThreadId]
xs     -> TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
tid (ThreadId
t ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
xs)

releaseLock :: ThreadId -> STM ()
releaseLock :: ThreadId -> STM ()
releaseLock ThreadId
tid = TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyLock
LockUninialized -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
  PyLock
LockFinalized   -> PyError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
  PyLock
LockUnlocked    -> PyInternalError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM ()) -> PyInternalError -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"releaseLock: releasing LockUnlocked"
  PyLock
LockedByGC      -> PyInternalError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM ()) -> PyInternalError -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"releaseLock: releasing LockedByGC"
  Locked ThreadId
t [ThreadId]
xs
    | ThreadId
t ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadId
tid  -> PyInternalError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM ()) -> PyInternalError -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"releaseLock: releasing  wrong lock"
    | Bool
otherwise -> TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$! case [ThreadId]
xs of
        []    -> PyLock
LockUnlocked
        ThreadId
t':[ThreadId]
ts -> ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
t' [ThreadId]
ts



----------------------------------------------------------------
-- Initialization and finalization
----------------------------------------------------------------

-- | Initialize python interpreter. If interpreter is already
--   initialized it's a noop. Calling after python was shut down will
--   result in error.
initializePython :: IO ()
-- See NOTE: [Python and threading]
initializePython :: IO ()
initializePython = IO CInt
[CU.exp| int { Py_IsInitialized() } |] IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  CInt
0 | Bool
rtsSupportsBoundThreads -> IO () -> IO ()
forall a. IO a -> IO a
runInBoundThread (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
doInializePython
    | Bool
otherwise               -> IO ()
doInializePython
  CInt
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Destroy python interpreter.
finalizePython :: IO ()
finalizePython :: IO ()
finalizePython = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ TVar PyState -> STM PyState
forall a. TVar a -> STM a
readTVar TVar PyState
globalPyState STM PyState -> (PyState -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyState
NotInitialized   -> PyError -> STM (IO ())
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
  PyState
InitFailed       -> PyError -> STM (IO ())
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
  PyState
Finalized        -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PyState
InInitialization -> STM (IO ())
forall a. STM a
retry
  PyState
InFinalization   -> STM (IO ())
forall a. STM a
retry
  -- We can simply call Py_Finalize
  PyState
Running1 -> IO () -> STM (IO ())
forall a. a -> STM a
checkLock (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
[C.block| void {
    PyGILState_Ensure();
    Py_Finalize();
    } |]
  -- We need to call Py_Finalize on main thread
  RunningN Chan (Ptr PyObject)
_ MVar EvalReq
lock_eval ThreadId
_ ThreadId
tid_gc -> IO () -> STM (IO ())
forall a. a -> STM a
checkLock (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
    ThreadId -> IO ()
killThread ThreadId
tid_gc
    resp <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    putMVar lock_eval $ StopReq resp
    takeMVar resp
  where
    checkLock :: b -> STM b
checkLock b
action = TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PyLock
LockUninialized -> PyInternalError -> STM b
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM b) -> PyInternalError -> STM b
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"finalizePython LockUninialized"
      PyLock
LockFinalized   -> PyInternalError -> STM b
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM b) -> PyInternalError -> STM b
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"finalizePython LockFinalized"
      Locked{}        -> STM b
forall a. STM a
retry
      PyLock
LockedByGC      -> STM b
forall a. STM a
retry
      PyLock
LockUnlocked    -> do
        TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock  PyLock
LockFinalized
        TVar PyState -> PyState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyState
globalPyState PyState
Finalized
        b -> STM b
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
action

-- | Bracket which ensures that action is executed with properly
--   initialized interpreter
withPython :: IO a -> IO a
withPython :: forall a. IO a -> IO a
withPython = IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ IO ()
initializePython IO ()
finalizePython


doInializePython :: IO ()
doInializePython :: IO ()
doInializePython = do
  -- First we need to grab global python lock on haskell side
  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
    TVar PyState -> STM PyState
forall a. TVar a -> STM a
readTVar TVar PyState
globalPyState STM PyState -> (PyState -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PyState
Finalized        -> PyError -> STM (IO ())
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
      PyState
InitFailed       -> PyError -> STM (IO ())
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
      PyState
InInitialization -> STM (IO ())
forall a. STM a
retry
      PyState
InFinalization   -> STM (IO ())
forall a. STM a
retry
      Running1{}       -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      RunningN{}       -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PyState
NotInitialized   -> do
        TVar PyState -> PyState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyState
globalPyState PyState
InInitialization
        let fini :: PyState -> IO ()
fini PyState
st = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TVar PyState -> PyState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyState
globalPyState (PyState -> STM ()) -> PyState -> STM ()
forall a b. (a -> b) -> a -> b
$ PyState
st
              TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock  (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ PyLock
LockUnlocked
        IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$
          (IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ if
            -- On multithreaded runtime create bound thread to make
            -- sure we can call python in its main thread.
            | Bool
rtsSupportsBoundThreads -> do
                lock_init <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
                lock_eval <- newEmptyMVar
                -- Main thread
                tid_main <- forkOS $ mainThread lock_init lock_eval
                takeMVar lock_init >>= \case
                  Bool
True  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Bool
False -> PyError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PyError
PyInitializationFailed
                -- GC thread
                gc_chan <- newChan
                tid_gc  <- forkOS $ gcThread gc_chan
                fini $ RunningN gc_chan lock_eval tid_main tid_gc
            -- Nothing special is needed on single threaded RTS
            | Bool
otherwise -> do
                IO Bool
doInializePythonIO IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Bool
True  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Bool
False -> PyError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PyError
PyInitializationFailed
                PyState -> IO ()
fini PyState
Running1
          ) IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar PyState -> PyState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyState
globalPyState PyState
InitFailed)

-- This action is executed on python's main thread
mainThread :: MVar Bool -> MVar EvalReq -> IO ()
mainThread :: MVar Bool -> MVar EvalReq -> IO ()
mainThread MVar Bool
lock_init MVar EvalReq
lock_eval = do
  r_init <- IO Bool
doInializePythonIO
  putMVar lock_init r_init
  case r_init of
    Bool
False -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
True  -> IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop ->
      (MVar EvalReq -> IO EvalReq
forall a. MVar a -> IO a
takeMVar MVar EvalReq
lock_eval IO EvalReq -> (InterruptMain -> IO EvalReq) -> IO EvalReq
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\InterruptMain
InterruptMain -> EvalReq -> IO EvalReq
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EvalReq
HereWeGoAgain)) IO EvalReq -> (EvalReq -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        EvalReq Py a
py MVar (Either SomeException a)
resp -> do
          res <- (a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a)
-> IO a -> IO (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Py a -> IO a
forall a. Py a -> IO a
runPy Py a
py) IO (Either SomeException a)
-> (SomeException -> IO (Either SomeException a))
-> IO (Either SomeException a)
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (Either SomeException a -> IO (Either SomeException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> IO (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> IO (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)
          putMVar resp res
          loop
        StopReq MVar ()
resp -> do
          IO ()
[C.block| void {
            PyGILState_Ensure();
            Py_Finalize();
            } |]
          MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
resp ()
        EvalReq
HereWeGoAgain -> IO ()
loop


doInializePythonIO :: IO Bool
doInializePythonIO :: IO Bool
doInializePythonIO = do
  -- FIXME: I'd like more direct access to argv
  argv0 <- IO String
getProgName
  argv  <- getArgs
  let n_argv = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
argv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  -- FIXME: For some reason sys.argv is initialized incorrectly. No
  --        easy way to debug. Will do for now
  r <- evalContT $ do
    p_argv0  <- ContT $ withWCString argv0
    p_argv   <- traverse (ContT . withWCString) argv
    ptr_argv <- ContT $ withArray (p_argv0 : p_argv)
    liftIO [C.block| int {
      // Now fill config
      PyStatus status;
      PyConfig cfg;
      PyConfig_InitPythonConfig( &cfg );
      cfg.parse_argv              = 0;
      cfg.install_signal_handlers = 0;
      //----------------
      status = PyConfig_SetBytesString(&cfg, &cfg.program_name, "XX");
      if( PyStatus_Exception(status) ) {
          goto error;
      }
      //----------------
      status = PyConfig_SetArgv(&cfg,
          $(int       n_argv),
          $(wchar_t** ptr_argv)
      );
      if( PyStatus_Exception(status) ) {
          goto error;
      };
      // Initialize interpreter
      status = Py_InitializeFromConfig(&cfg);
      if( PyStatus_Exception(status) ) {
          goto error;
      };
      PyConfig_Clear(&cfg);
      // Release GIL so other threads may take it
      PyEval_SaveThread();
      return 0;
      // Error case
      error:
      PyConfig_Clear(&cfg);
      return 1;
      } |]
  return $! r == 0


----------------------------------------------------------------
-- Running Py monad
----------------------------------------------------------------

data EvalReq
  = forall a. EvalReq (Py a) (MVar (Either SomeException a))
  | StopReq (MVar ())
  | HereWeGoAgain

data InterruptMain = InterruptMain
  deriving stock    Int -> InterruptMain -> ShowS
[InterruptMain] -> ShowS
InterruptMain -> String
(Int -> InterruptMain -> ShowS)
-> (InterruptMain -> String)
-> ([InterruptMain] -> ShowS)
-> Show InterruptMain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InterruptMain -> ShowS
showsPrec :: Int -> InterruptMain -> ShowS
$cshow :: InterruptMain -> String
show :: InterruptMain -> String
$cshowList :: [InterruptMain] -> ShowS
showList :: [InterruptMain] -> ShowS
Show
  deriving anyclass Show InterruptMain
Typeable InterruptMain
(Typeable InterruptMain, Show InterruptMain) =>
(InterruptMain -> SomeException)
-> (SomeException -> Maybe InterruptMain)
-> (InterruptMain -> String)
-> (InterruptMain -> Bool)
-> Exception InterruptMain
SomeException -> Maybe InterruptMain
InterruptMain -> Bool
InterruptMain -> String
InterruptMain -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: InterruptMain -> SomeException
toException :: InterruptMain -> SomeException
$cfromException :: SomeException -> Maybe InterruptMain
fromException :: SomeException -> Maybe InterruptMain
$cdisplayException :: InterruptMain -> String
displayException :: InterruptMain -> String
$cbacktraceDesired :: InterruptMain -> Bool
backtraceDesired :: InterruptMain -> Bool
Exception

-- | Execute python action. It will take and hold global lock while
--   code is executed. Python exceptions raised during execution are
--   converted to haskell exception 'PyError'.
runPy :: Py a -> IO a
-- See NOTE: [Python and threading]
runPy :: forall a. Py a -> IO a
runPy Py a
py
  | Bool
rtsSupportsBoundThreads = IO a -> IO a
forall a. IO a -> IO a
runInBoundThread IO a
go -- Multithreaded RTS
  | Bool
otherwise               = IO a
go                  -- Single-threaded RTS
  where
    -- We check whether interpreter is initialized. Throw exception if
    -- it wasn't. Better than segfault isn't it?
    go :: IO a
go = IO a -> IO a
forall a. IO a -> IO a
ensurePyLock (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Py a -> IO a
forall a. Py a -> IO a
unsafeRunPy (Py a -> Py a
forall a. Py a -> Py a
ensureGIL Py a
py)

-- | Same as 'runPy' but will make sure that code is run in python's
--   main thread. It's thread in which python's interpreter was
--   initialized. Some python's libraries may need that. It has higher
--   call overhead compared to 'runPy'.
runPyInMain :: Py a -> IO a
-- See NOTE: [Python and threading]
runPyInMain :: forall a. Py a -> IO a
runPyInMain Py a
py
  -- Multithreaded RTS
  | Bool
rtsSupportsBoundThreads = do
      tid <- IO ThreadId
myThreadId
      bracket (acquireMain tid) fst snd
  -- Single-threaded RTS
  | Bool
otherwise = Py a -> IO a
forall a. Py a -> IO a
runPy Py a
py
  where
    acquireMain :: ThreadId -> IO (IO (), IO a)
acquireMain ThreadId
tid = STM (IO (), IO a) -> IO (IO (), IO a)
forall a. STM a -> IO a
atomically (STM (IO (), IO a) -> IO (IO (), IO a))
-> STM (IO (), IO a) -> IO (IO (), IO a)
forall a b. (a -> b) -> a -> b
$ TVar PyState -> STM PyState
forall a. TVar a -> STM a
readTVar TVar PyState
globalPyState STM PyState -> (PyState -> STM (IO (), IO a)) -> STM (IO (), IO a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PyState
NotInitialized   -> PyError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
      PyState
InitFailed       -> PyError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM PyError
PyInitializationFailed
      PyState
Finalized        -> PyError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
      PyState
InInitialization -> STM (IO (), IO a)
forall a. STM a
retry
      PyState
InFinalization   -> STM (IO (), IO a)
forall a. STM a
retry
      PyState
Running1         -> PyInternalError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM (PyInternalError -> STM (IO (), IO a))
-> PyInternalError -> STM (IO (), IO a)
forall a b. (a -> b) -> a -> b
$ String -> PyInternalError
PyInternalError String
"runPyInMain: Running1"
      RunningN Chan (Ptr PyObject)
_ MVar EvalReq
eval_lock ThreadId
tid_main ThreadId
_ -> TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM (IO (), IO a)) -> STM (IO (), IO a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PyLock
LockUninialized -> PyError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonNotInitialized
        PyLock
LockFinalized   -> PyError -> STM (IO (), IO a)
forall e a. Exception e => e -> STM a
throwSTM PyError
PythonIsFinalized
        PyLock
LockedByGC      -> STM (IO (), IO a)
forall a. STM a
retry
        -- We need to send closure to main python thread when we're grabbing lock.
        PyLock
LockUnlocked    -> do
          TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
tid_main []
          (IO (), IO a) -> STM (IO (), IO a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( STM () -> IO ()
forall a. STM a -> IO a
atomically (ThreadId -> STM ()
releaseLock ThreadId
tid_main)
               , ThreadId -> MVar EvalReq -> IO a
evalInOtherThread ThreadId
tid_main MVar EvalReq
eval_lock
               )
        -- If we513 can grab lock and main thread taken lock we're
        -- already executing on main thread. We can simply execute code
        Locked ThreadId
t [ThreadId]
ts
          | ThreadId
t ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadId
tid
            -> STM (IO (), IO a)
forall a. STM a
retry
          | ThreadId
t ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid_main Bool -> Bool -> Bool
|| (ThreadId
tid_main ThreadId -> [ThreadId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ThreadId]
ts) -> do
              TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
t (ThreadId
t ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
ts)
              (IO (), IO a) -> STM (IO (), IO a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( STM () -> IO ()
forall a. STM a -> IO a
atomically (ThreadId -> STM ()
releaseLock ThreadId
t)
                   , Py a -> IO a
forall a. Py a -> IO a
unsafeRunPy (Py a -> IO a) -> Py a -> IO a
forall a b. (a -> b) -> a -> b
$ Py a -> Py a
forall a. Py a -> Py a
ensureGIL Py a
py
                   )
          | Bool
otherwise -> do
              TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock (PyLock -> STM ()) -> PyLock -> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> [ThreadId] -> PyLock
Locked ThreadId
tid_main (ThreadId
t ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
ts)
              (IO (), IO a) -> STM (IO (), IO a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( STM () -> IO ()
forall a. STM a -> IO a
atomically (ThreadId -> STM ()
releaseLock ThreadId
tid_main)
                   , ThreadId -> MVar EvalReq -> IO a
evalInOtherThread ThreadId
tid_main MVar EvalReq
eval_lock
                   )
    --
    evalInOtherThread :: ThreadId -> MVar EvalReq -> IO a
evalInOtherThread ThreadId
tid_main MVar EvalReq
eval_lock = do
      r <- IO (Either SomeException a) -> IO (Either SomeException a)
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO (Either SomeException a) -> IO (Either SomeException a))
-> IO (Either SomeException a) -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ do resp <- IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar
                      putMVar eval_lock $ EvalReq py resp
                      takeMVar resp `onException` throwTo tid_main InterruptMain
      either throwM pure r


-- | Execute python action. This function is unsafe and should be only
--   called in thread of interpreter.
unsafeRunPy :: Py a -> IO a
unsafeRunPy :: forall a. Py a -> IO a
unsafeRunPy (Py IO a
io) = IO a
io



----------------------------------------------------------------
-- GC-related functions
----------------------------------------------------------------

-- | Wrap raw python object into
newPyObject :: Ptr PyObject -> Py PyObject
-- See NOTE: [GC]
newPyObject :: Ptr PyObject -> Py PyObject
newPyObject Ptr PyObject
p = IO PyObject -> Py PyObject
forall a. IO a -> Py a
Py (IO PyObject -> Py PyObject) -> IO PyObject -> Py PyObject
forall a b. (a -> b) -> a -> b
$ do
  fptr <- Ptr PyObject -> IO (ForeignPtr PyObject)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr PyObject
p
  GHC.addForeignPtrFinalizer fptr $
    readTVarIO globalPyState >>= \case
      RunningN Chan (Ptr PyObject)
ch MVar EvalReq
_ ThreadId
_ ThreadId
_  -> Chan (Ptr PyObject) -> Ptr PyObject -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Ptr PyObject)
ch Ptr PyObject
p
      PyState
Running1           -> Ptr PyObject -> IO ()
singleThreadedDecrefCG Ptr PyObject
p
      PyState
_                  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  pure $ PyObject fptr

-- | Thread doing garbage collection for python object in
--   multithreaded runtime.
gcThread :: Chan (Ptr PyObject) -> IO ()
gcThread :: Chan (Ptr PyObject) -> IO ()
gcThread Chan (Ptr PyObject)
ch = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Ptr PyObject -> IO ()
decrefGC (Ptr PyObject -> IO ()) -> IO (Ptr PyObject) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Chan (Ptr PyObject) -> IO (Ptr PyObject)
forall a. Chan a -> IO a
readChan Chan (Ptr PyObject)
ch

decrefGC :: Ptr PyObject -> IO ()
decrefGC :: Ptr PyObject -> IO ()
decrefGC Ptr PyObject
p = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ TVar PyLock -> STM PyLock
forall a. TVar a -> STM a
readTVar TVar PyLock
globalPyLock STM PyLock -> (PyLock -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyLock
LockUninialized -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PyLock
LockFinalized   -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PyLock
LockedByGC      -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Locked{}        -> STM (IO ())
forall a. STM a
retry
  PyLock
LockUnlocked    -> do
    TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock PyLock
LockedByGC
    IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ do
      Ptr PyObject -> IO ()
gcDecref Ptr PyObject
p IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar PyLock -> PyLock -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar PyLock
globalPyLock PyLock
LockUnlocked)

singleThreadedDecrefCG :: Ptr PyObject -> IO ()
singleThreadedDecrefCG :: Ptr PyObject -> IO ()
singleThreadedDecrefCG Ptr PyObject
p = TVar PyLock -> IO PyLock
forall a. TVar a -> IO a
readTVarIO TVar PyLock
globalPyLock IO PyLock -> (PyLock -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PyLock
LockUninialized -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PyLock
LockFinalized   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PyLock
LockedByGC      -> Ptr PyObject -> IO ()
gcDecref Ptr PyObject
p
  Locked{}        -> Ptr PyObject -> IO ()
gcDecref Ptr PyObject
p
  PyLock
LockUnlocked    -> Ptr PyObject -> IO ()
gcDecref Ptr PyObject
p

gcDecref :: Ptr PyObject -> IO ()
gcDecref :: Ptr PyObject -> IO ()
gcDecref Ptr PyObject
p = [CU.block| void {
  PyGILState_STATE st = PyGILState_Ensure();
  Py_XDECREF( $(PyObject* p) );
  PyGILState_Release(st);
  } |]


----------------------------------------------------------------
-- C-API wrappers
----------------------------------------------------------------

-- | Ensure that we hold GIL for duration of action
ensureGIL :: Py a -> Py a
ensureGIL :: forall a. Py a -> Py a
ensureGIL Py a
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.
  gil_state <- IO CInt -> Py CInt
forall a. IO a -> Py a
Py IO CInt
[CU.exp| int { PyGILState_Ensure() } |]
  action `finally` Py [CU.exp| void { PyGILState_Release($(int gil_state)) } |]

-- | Drop GIL temporarily
dropGIL :: IO a -> Py a
dropGIL :: forall a. IO a -> Py a
dropGIL IO a
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 <- IO (Ptr PyThreadState) -> Py (Ptr PyThreadState)
forall a. IO a -> Py a
Py IO (Ptr PyThreadState)
[CU.exp| PyThreadState* { PyEval_SaveThread() } |]
  Py $ interruptible action
        `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |]


----------------------------------------------------------------
-- Conversion of exceptions
----------------------------------------------------------------

-- | Convert haskell exception to python exception. Always returns
--   NULL.
convertHaskell2Py :: SomeException -> Py (Ptr PyObject)
convertHaskell2Py :: SomeException -> Py (Ptr PyObject)
convertHaskell2Py SomeException
err = IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a. IO a -> Py a
Py (IO (Ptr PyObject) -> Py (Ptr PyObject))
-> IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a b. (a -> b) -> a -> b
$ do
  String -> (CString -> IO (Ptr PyObject)) -> IO (Ptr PyObject)
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"Haskell exception: "String -> ShowS
forall a. [a] -> [a] -> [a]
++SomeException -> String
forall a. Show a => a -> String
show SomeException
err) ((CString -> IO (Ptr PyObject)) -> IO (Ptr PyObject))
-> (CString -> IO (Ptr PyObject)) -> IO (Ptr PyObject)
forall a b. (a -> b) -> a -> b
$ \CString
p_err -> do
    [CU.block| PyObject* {
      PyErr_SetString(PyExc_RuntimeError, $(char *p_err));
      return NULL;
      } |]

-- | Convert python exception to haskell exception. Should only be
--   called if there's unhandled python exception. Clears exception.
convertPy2Haskell :: Py PyException
convertPy2Haskell :: Py PyException
convertPy2Haskell = Program PyException PyException -> Py PyException
forall a. Program a a -> Py a
runProgram (Program PyException PyException -> Py PyException)
-> Program PyException PyException -> Py PyException
forall a b. (a -> b) -> a -> b
$ do
  p_errors <- forall a r. Storable a => Int -> Program r (Ptr a)
withPyAllocaArray @(Ptr PyObject) Int
3
  -- Fetch error indicator
  (p_type, p_value) <- progIO $ do
    [CU.block| void {
       PyObject **p = $(PyObject** p_errors);
       PyErr_Fetch(p, p+1, p+2);
       }|]
    p_type  <- peekElemOff p_errors 0
    p_value <- peekElemOff p_errors 1
    -- Traceback is not used ATM
    pure (p_type,p_value)
  -- Convert exception type and value to strings.
  progPy $ do
    s_type  <- pyobjectStrAsHask p_type
    s_value <- pyobjectStrAsHask p_value
    incref p_value
    exc     <- newPyObject p_value
    let bad_str = String
"__str__ call failed"
    pure $ PyException
      { ty        = fromMaybe bad_str s_type
      , str       = fromMaybe bad_str s_value
      , exception = exc
      }

-- | Throw python error as haskell exception if it's raised.
checkThrowPyError :: Py ()
checkThrowPyError :: Py ()
checkThrowPyError =
  IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a. IO a -> Py a
Py IO (Ptr PyObject)
[CU.exp| PyObject* { PyErr_Occurred() } |] Py (Ptr PyObject) -> (Ptr PyObject -> Py ()) -> Py ()
forall a b. Py a -> (a -> Py b) -> Py b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Ptr PyObject
NULL -> () -> Py ()
forall a. a -> Py a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Ptr PyObject
_    -> PyError -> Py ()
forall e a. (HasCallStack, Exception e) => e -> Py a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (PyError -> Py ())
-> (PyException -> PyError) -> PyException -> Py ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PyException -> PyError
PyError (PyException -> Py ()) -> Py PyException -> Py ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Py PyException
convertPy2Haskell

-- | Throw python error as haskell exception if it's raised. If it's
--   not that internal error. Another exception will be raised
mustThrowPyError :: Py a
mustThrowPyError :: forall a. Py a
mustThrowPyError =
  IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a. IO a -> Py a
Py IO (Ptr PyObject)
[CU.exp| PyObject* { PyErr_Occurred() } |] Py (Ptr PyObject) -> (Ptr PyObject -> Py a) -> Py a
forall a b. Py a -> (a -> Py b) -> Py b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Ptr PyObject
NULL -> String -> Py a
forall a. HasCallStack => String -> a
error (String -> Py a) -> String -> Py a
forall a b. (a -> b) -> a -> b
$ String
"mustThrowPyError: no python exception raised."
    Ptr PyObject
_    -> PyError -> Py a
forall e a. (HasCallStack, Exception e) => e -> Py a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (PyError -> Py a)
-> (PyException -> PyError) -> PyException -> Py a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PyException -> PyError
PyError (PyException -> Py a) -> Py PyException -> Py a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Py PyException
convertPy2Haskell

-- | Calls mustThrowPyError if pointer is null or returns it unchanged
throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject)
throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject)
throwOnNULL = \case
  Ptr PyObject
NULL -> Py (Ptr PyObject)
forall a. Py a
mustThrowPyError
  Ptr PyObject
p    -> Ptr PyObject -> Py (Ptr PyObject)
forall a. a -> Py a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr PyObject
p

checkThrowBadPyType :: Py ()
checkThrowBadPyType :: Py ()
checkThrowBadPyType = do
  r <- IO CInt -> Py CInt
forall a. IO a -> Py a
Py IO CInt
[CU.block| int {
    if( PyErr_Occurred() ) {
        PyErr_Clear();
        return 1;
    }
    return 0;
    } |]
  case r of
    CInt
0 -> () -> Py ()
forall a. a -> Py a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    CInt
_ -> PyError -> Py ()
forall e a. (HasCallStack, Exception e) => e -> Py a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PyError
BadPyType


----------------------------------------------------------------
-- Eval/exec
----------------------------------------------------------------

-- | Type class for values representing python dictionaries containing
--   global or local variables.
--
--   @since 0.2@
class Namespace a where
  -- | Returns dictionary object. Caller should take ownership of
  --   returned object.
  basicNamespaceDict :: a -> Py (Ptr PyObject)


-- | Namespace for the top level code execution. It corresponds to
--   @\__dict\__@ field of a @\__main\__@ module.
--
--   @since 0.2@
data Main = Main

instance Namespace Main where
  basicNamespaceDict :: Main -> Py (Ptr PyObject)
basicNamespaceDict Main
_ =
    Ptr PyObject -> Py (Ptr PyObject)
throwOnNULL (Ptr PyObject -> Py (Ptr PyObject))
-> Py (Ptr PyObject) -> Py (Ptr PyObject)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a. IO a -> Py a
Py IO (Ptr PyObject)
[CU.block| PyObject* {
      PyObject* main_module = PyImport_AddModule("__main__");
      if( PyErr_Occurred() )
          return NULL;
      PyObject* dict = PyModule_GetDict(main_module);
      Py_XINCREF(dict);
      return dict;
      }|]


-- | Temporary namespace which get destroyed after execution
--
--   @since 0.2@
data Temp = Temp

instance Namespace Temp where
  basicNamespaceDict :: Temp -> Py (Ptr PyObject)
basicNamespaceDict Temp
_ = Py (Ptr PyObject)
basicNewDict


-- | Newtype wrapper for bare python object. It's assumed to be a
--   dictionary. This is not checked.
--
--   @since 0.2@
newtype DictPtr = DictPtr (Ptr PyObject)

instance Namespace DictPtr where
  basicNamespaceDict :: DictPtr -> Py (Ptr PyObject)
basicNamespaceDict (DictPtr Ptr PyObject
p) = Ptr PyObject
p Ptr PyObject -> Py () -> Py (Ptr PyObject)
forall a b. a -> Py b -> Py a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ptr PyObject -> Py ()
incref Ptr PyObject
p


-- | Newtype wrapper for python dictionary. It's not checked whether
--   object is actually dictionary.
--
--   @since 0.2@
newtype Dict = Dict PyObject

instance Namespace Dict where
  basicNamespaceDict :: Dict -> Py (Ptr PyObject)
basicNamespaceDict (Dict PyObject
d)
    -- NOTE: We're incrementing counter inside bracket so we're safe.
    = PyObject
-> (Ptr PyObject -> Py (Ptr PyObject)) -> Py (Ptr PyObject)
forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a
unsafeWithPyObject PyObject
d (DictPtr -> Py (Ptr PyObject)
forall a. Namespace a => a -> Py (Ptr PyObject)
basicNamespaceDict (DictPtr -> Py (Ptr PyObject))
-> (Ptr PyObject -> DictPtr) -> Ptr PyObject -> Py (Ptr PyObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PyObject -> DictPtr
DictPtr)

-- | Newtype wrapper over module object.
--
--   @since 0.2@
newtype ModulePtr = ModulePtr (Ptr PyObject)

instance Namespace ModulePtr where
  basicNamespaceDict :: ModulePtr -> Py (Ptr PyObject)
basicNamespaceDict (ModulePtr Ptr PyObject
p) = do
    Ptr PyObject -> Py (Ptr PyObject)
throwOnNULL (Ptr PyObject -> Py (Ptr PyObject))
-> Py (Ptr PyObject) -> Py (Ptr PyObject)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr PyObject) -> Py (Ptr PyObject)
forall a. IO a -> Py a
Py [CU.block| PyObject* {
      PyObject* dict = PyModule_GetDict($(PyObject* p));
      Py_XINCREF(dict);
      return dict;
      }|]

-- | Newtype wrapper over module object.
newtype Module = Module PyObject

instance Namespace Module where
  basicNamespaceDict :: Module -> Py (Ptr PyObject)
basicNamespaceDict (Module PyObject
d)
    -- NOTE: We're incrementing counter inside bracket so we're safe.
    = PyObject
-> (Ptr PyObject -> Py (Ptr PyObject)) -> Py (Ptr PyObject)
forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a
unsafeWithPyObject PyObject
d (ModulePtr -> Py (Ptr PyObject)
forall a. Namespace a => a -> Py (Ptr PyObject)
basicNamespaceDict (ModulePtr -> Py (Ptr PyObject))
-> (Ptr PyObject -> ModulePtr) -> Ptr PyObject -> Py (Ptr PyObject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PyObject -> ModulePtr
ModulePtr)


-- | Evaluate python expression. This is wrapper over python's @eval@.
--
--   @since 0.2@
eval :: (Namespace global, Namespace local)
     => global  -- ^ Data type providing global variables dictionary
     -> local   -- ^ Data type providing local variables dictionary
     -> PyQuote -- ^ Source code
     -> Py PyObject
eval :: forall global local.
(Namespace global, Namespace local) =>
global -> local -> PyQuote -> Py PyObject
eval global
globals local
locals PyQuote
q = Program PyObject PyObject -> Py PyObject
forall a. Program a a -> Py a
runProgram (Program PyObject PyObject -> Py PyObject)
-> Program PyObject PyObject -> Py PyObject
forall a b. (a -> b) -> a -> b
$ do
  p_py      <- Code -> Program PyObject CString
forall r. Code -> Program r CString
unsafeWithCode PyQuote
q.code
  p_globals <- takeOwnership =<< progPy (basicNamespaceDict globals)
  p_locals  <- takeOwnership =<< progPy (basicNamespaceDict locals)
  progPy $ do
    q.binder.bind p_locals
    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), "<interactive>", Py_eval_input);
      if( PyErr_Occurred() ) {
          return NULL;
      }
      // Evaluate expression
      PyObject* r = PyEval_EvalCode(code, globals, locals);
      Py_DECREF(code);
      return r;
      }|]
    checkThrowPyError
    newPyObject p_res
{-# SPECIALIZE eval :: Main -> Temp -> PyQuote -> Py PyObject #-}

-- | Evaluate sequence of python statements This is wrapper over python's @exec@.
--
--   @since 0.2@
exec :: (Namespace global, Namespace local)
     => global  -- ^ Data type providing global variables dictionary
     -> local   -- ^ Data type providing local variables dictionary
     -> PyQuote -- ^ Source code
     -> Py ()
exec :: forall global local.
(Namespace global, Namespace local) =>
global -> local -> PyQuote -> Py ()
exec global
globals local
locals PyQuote
q = Program () () -> Py ()
forall a. Program a a -> Py a
runProgram (Program () () -> Py ()) -> Program () () -> Py ()
forall a b. (a -> b) -> a -> b
$ do
  p_py      <- Code -> Program () CString
forall r. Code -> Program r CString
unsafeWithCode PyQuote
q.code
  p_globals <- takeOwnership =<< progPy (basicNamespaceDict globals)
  p_locals  <- takeOwnership =<< progPy (basicNamespaceDict locals)
  progPy $ do
    q.binder.bind p_locals
    Py[C.block| void {
      PyObject* globals = $(PyObject* p_globals);
      PyObject* locals  = $(PyObject* p_locals);
      // Compile code
      PyObject *code = Py_CompileString($(char* p_py), "<interactive>", Py_file_input);
      if( PyErr_Occurred() ){
          return;
      }
      // Execute statements
      PyObject* res = PyEval_EvalCode(code, globals, locals);
      Py_XDECREF(res);
      Py_DECREF(code);
      } |]
    checkThrowPyError
{-# SPECIALIZE exec :: Main -> Main -> PyQuote -> Py () #-}
{-# SPECIALIZE exec :: Main -> Temp -> PyQuote -> Py () #-}

-- | Obtain pointer to code
unsafeWithCode :: Code -> Program r (Ptr CChar)
unsafeWithCode :: forall r. Code -> Program r CString
unsafeWithCode (Code ByteString
bs) = ContT r Py CString -> Program r CString
forall r a. ContT r Py a -> Program r a
Program (ContT r Py CString -> Program r CString)
-> ContT r Py CString -> Program r CString
forall a b. (a -> b) -> a -> b
$ ((CString -> Py r) -> Py r) -> ContT r Py CString
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((CString -> Py r) -> Py r) -> ContT r Py CString)
-> ((CString -> Py r) -> Py r) -> ContT r Py CString
forall a b. (a -> b) -> a -> b
$ \CString -> Py r
fun ->
  IO r -> Py r
forall a. IO a -> Py a
Py (ByteString -> (CString -> IO r) -> IO r
forall a. ByteString -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((CString -> IO r) -> IO r) -> (CString -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ Py r -> IO r
forall a. Py a -> IO a
unsafeRunPy (Py r -> IO r) -> (CString -> Py r) -> CString -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Py r
fun)


----------------------------------------------------------------
-- Debugging
----------------------------------------------------------------

debugPrintPy :: Ptr PyObject -> Py ()
debugPrintPy :: Ptr PyObject -> Py ()
debugPrintPy Ptr PyObject
p = IO () -> Py ()
forall a. IO a -> Py a
Py [CU.block| void {
  PyObject_Print($(PyObject *p), stdout, 0);
  printf(" [REF=%li]\n", Py_REFCNT($(PyObject *p)) );
  } |]