{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Runtime.Interpreter
( module GHC.Runtime.Interpreter.Types
, evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
, resumeStmt
, abandonStmt
, evalIO
, evalString
, evalStringToIOString
, mallocData
, createBCOs
, addSptEntry
, mkCostCentres
, costCentreStackInfo
, newBreakArray
, newModuleName
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
, getClosure
, getModBreaks
, seqHValue
, evalBreakpointToId
, interpreterDynamic
, interpreterProfiled
, initObjLinker
, lookupSymbol
, lookupSymbolInDLL
, lookupClosure
, loadDLL
, loadArchive
, loadObj
, unloadObj
, addLibrarySearchPath
, removeLibrarySearchPath
, resolveObjs
, findSystemLibrary
, interpCmd
, withExtInterp
, withExtInterpStatus
, withIServ
, withJSInterp
, stopInterp
, purgeLookupSymbolCache
, freeReallyRemoteRef
, freeHValueRefs
, mkFinalizedHValue
, wormhole, wormholeRef
, fromEvalResult
, Message (..)
, module GHC.Runtime.Interpreter.Process
) where
import GHC.Prelude
import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Interpreter.JS
import GHC.Runtime.Interpreter.Wasm
import GHC.Runtime.Interpreter.Process
import GHC.Runtime.Utils
import GHCi.Message
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
import GHC.Types.Breakpoint
import GHC.ByteCode.Types
import GHC.Linker.Types
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Utils.Panic
import GHC.Utils.Exception as Ex
import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
import GHCi.Run
import GHC.Platform.Ways
#endif
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
import Data.Array ((!))
import Data.IORef
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
interpCmd :: Binary a => Interp -> Message a -> IO a
interpCmd :: forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp Message a
msg = case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> Message a -> IO a
forall a. Message a -> IO a
run Message a
msg
#endif
ExternalInterp ExtInterp
ext -> ExtInterp -> (forall d. ExtInterpInstance d -> IO a) -> IO a
forall (m :: * -> *) a.
ExceptionMonad m =>
ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
withExtInterp ExtInterp
ext ((forall d. ExtInterpInstance d -> IO a) -> IO a)
-> (forall d. ExtInterpInstance d -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ExtInterpInstance d
inst ->
IO a -> IO a
forall a. IO a -> IO a
uninterruptibleMask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
ExtInterpInstance d -> Message a -> IO a
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
inst Message a
msg
withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
withExtInterp :: forall (m :: * -> *) a.
ExceptionMonad m =>
ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
withExtInterp ExtInterp
ext forall d. ExtInterpInstance d -> m a
action = case ExtInterp
ext of
ExtJS JSInterp
i -> JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a
withJSInterp JSInterp
i ExtInterpInstance JSInterpExtra -> m a
forall d. ExtInterpInstance d -> m a
action
ExtWasm WasmInterp
i -> WasmInterp -> (ExtInterpInstance () -> m a) -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
WasmInterp -> (ExtInterpInstance () -> m a) -> m a
withWasmInterp WasmInterp
i ExtInterpInstance () -> m a
forall d. ExtInterpInstance d -> m a
action
ExtIServ IServ
i -> IServ -> (ExtInterpInstance () -> m a) -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
IServ -> (ExtInterpInstance () -> m a) -> m a
withIServ IServ
i ExtInterpInstance () -> m a
forall d. ExtInterpInstance d -> m a
action
withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
withExtInterpStatus :: forall {k} (m :: k -> *) (a :: k).
ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
withExtInterpStatus ExtInterp
ext forall d. ExtInterpStatusVar d -> m a
action = case ExtInterp
ext of
ExtJS JSInterp
i -> ExtInterpStatusVar JSInterpExtra -> m a
forall d. ExtInterpStatusVar d -> m a
action (JSInterp -> ExtInterpStatusVar JSInterpExtra
forall cfg details.
ExtInterpState cfg details -> ExtInterpStatusVar details
interpStatus JSInterp
i)
ExtWasm WasmInterp
i -> ExtInterpStatusVar () -> m a
forall d. ExtInterpStatusVar d -> m a
action (ExtInterpStatusVar () -> m a) -> ExtInterpStatusVar () -> m a
forall a b. (a -> b) -> a -> b
$ WasmInterp -> ExtInterpStatusVar ()
forall cfg details.
ExtInterpState cfg details -> ExtInterpStatusVar details
interpStatus WasmInterp
i
ExtIServ IServ
i -> ExtInterpStatusVar () -> m a
forall d. ExtInterpStatusVar d -> m a
action (IServ -> ExtInterpStatusVar ()
forall cfg details.
ExtInterpState cfg details -> ExtInterpStatusVar details
interpStatus IServ
i)
withIServ
:: (ExceptionMonad m)
=> IServ -> (ExtInterpInstance () -> m a) -> m a
withIServ :: forall (m :: * -> *) a.
ExceptionMonad m =>
IServ -> (ExtInterpInstance () -> m a) -> m a
withIServ (ExtInterpState IServConfig
cfg ExtInterpStatusVar ()
mstate) ExtInterpInstance () -> m a
action = do
inst <- IServConfig
-> (IServConfig -> IO (ExtInterpInstance ()))
-> ExtInterpStatusVar ()
-> m (ExtInterpInstance ())
forall (m :: * -> *) cfg d.
ExceptionMonad m =>
cfg
-> (cfg -> IO (ExtInterpInstance d))
-> ExtInterpStatusVar d
-> m (ExtInterpInstance d)
spawnInterpMaybe IServConfig
cfg IServConfig -> IO (ExtInterpInstance ())
spawnIServ ExtInterpStatusVar ()
mstate
action inst
withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a
withJSInterp :: forall (m :: * -> *) a.
ExceptionMonad m =>
JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a
withJSInterp (ExtInterpState JSInterpConfig
cfg ExtInterpStatusVar JSInterpExtra
mstate) ExtInterpInstance JSInterpExtra -> m a
action = do
inst <- JSInterpConfig
-> (JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra))
-> ExtInterpStatusVar JSInterpExtra
-> m (ExtInterpInstance JSInterpExtra)
forall (m :: * -> *) cfg d.
ExceptionMonad m =>
cfg
-> (cfg -> IO (ExtInterpInstance d))
-> ExtInterpStatusVar d
-> m (ExtInterpInstance d)
spawnInterpMaybe JSInterpConfig
cfg JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra)
spawnJSInterp ExtInterpStatusVar JSInterpExtra
mstate
action inst
withWasmInterp :: ExceptionMonad m => WasmInterp -> (ExtInterpInstance () -> m a) -> m a
withWasmInterp :: forall (m :: * -> *) a.
ExceptionMonad m =>
WasmInterp -> (ExtInterpInstance () -> m a) -> m a
withWasmInterp (ExtInterpState WasmInterpConfig
cfg ExtInterpStatusVar ()
mstate) ExtInterpInstance () -> m a
action = do
inst <- WasmInterpConfig
-> (WasmInterpConfig -> IO (ExtInterpInstance ()))
-> ExtInterpStatusVar ()
-> m (ExtInterpInstance ())
forall (m :: * -> *) cfg d.
ExceptionMonad m =>
cfg
-> (cfg -> IO (ExtInterpInstance d))
-> ExtInterpStatusVar d
-> m (ExtInterpInstance d)
spawnInterpMaybe WasmInterpConfig
cfg WasmInterpConfig -> IO (ExtInterpInstance ())
spawnWasmInterp ExtInterpStatusVar ()
mstate
action inst
spawnInterpMaybe :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpStatusVar d -> m (ExtInterpInstance d)
spawnInterpMaybe :: forall (m :: * -> *) cfg d.
ExceptionMonad m =>
cfg
-> (cfg -> IO (ExtInterpInstance d))
-> ExtInterpStatusVar d
-> m (ExtInterpInstance d)
spawnInterpMaybe cfg
cfg cfg -> IO (ExtInterpInstance d)
spawn ExtInterpStatusVar d
mstatus = do
inst <- IO (ExtInterpInstance d) -> m (ExtInterpInstance d)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExtInterpInstance d) -> m (ExtInterpInstance d))
-> IO (ExtInterpInstance d) -> m (ExtInterpInstance d)
forall a b. (a -> b) -> a -> b
$ ExtInterpStatusVar d
-> (InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d), ExtInterpInstance d))
-> IO (ExtInterpInstance d)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVarMasked ExtInterpStatusVar d
mstatus ((InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d), ExtInterpInstance d))
-> IO (ExtInterpInstance d))
-> (InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d), ExtInterpInstance d))
-> IO (ExtInterpInstance d)
forall a b. (a -> b) -> a -> b
$ \case
InterpStatus (ExtInterpInstance d)
InterpPending -> do
inst <- cfg -> IO (ExtInterpInstance d)
spawn cfg
cfg
pure (InterpRunning inst, inst)
InterpRunning ExtInterpInstance d
inst -> do
(InterpStatus (ExtInterpInstance d), ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d), ExtInterpInstance d)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExtInterpInstance d -> InterpStatus (ExtInterpInstance d)
forall inst. inst -> InterpStatus inst
InterpRunning ExtInterpInstance d
inst, ExtInterpInstance d
inst)
pending_frees <- liftIO $ swapMVar (instPendingFrees inst) []
liftIO $ when (not (null (pending_frees))) $
sendMessage inst (FreeHValueRefs pending_frees)
pure inst
withExtInterpMaybe
:: (ExceptionMonad m)
=> ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a
withExtInterpMaybe :: forall (m :: * -> *) a.
ExceptionMonad m =>
ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a
withExtInterpMaybe ExtInterp
ext forall d. Maybe (ExtInterpInstance d) -> m a
action = ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
forall {k} (m :: k -> *) (a :: k).
ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
withExtInterpStatus ExtInterp
ext ((forall d. ExtInterpStatusVar d -> m a) -> m a)
-> (forall d. ExtInterpStatusVar d -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ExtInterpStatusVar d
mstate -> do
IO (InterpStatus (ExtInterpInstance d))
-> m (InterpStatus (ExtInterpInstance d))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExtInterpStatusVar d -> IO (InterpStatus (ExtInterpInstance d))
forall a. MVar a -> IO a
readMVar ExtInterpStatusVar d
mstate) m (InterpStatus (ExtInterpInstance d))
-> (InterpStatus (ExtInterpInstance d) -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
InterpPending {} -> Maybe (ExtInterpInstance (ZonkAny 0)) -> m a
forall d. Maybe (ExtInterpInstance d) -> m a
action Maybe (ExtInterpInstance (ZonkAny 0))
forall a. Maybe a
Nothing
InterpRunning ExtInterpInstance d
inst -> Maybe (ExtInterpInstance d) -> m a
forall d. Maybe (ExtInterpInstance d) -> m a
action (ExtInterpInstance d -> Maybe (ExtInterpInstance d)
forall a. a -> Maybe a
Just ExtInterpInstance d
inst)
evalStmt
:: Interp
-> EvalOpts
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt :: Interp
-> EvalOpts
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp EvalOpts
opts EvalExpr ForeignHValue
foreign_expr = do
status <- EvalExpr ForeignHValue
-> (EvalExpr HValueRef -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
foreign_expr ((EvalExpr HValueRef -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> (EvalExpr HValueRef -> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
expr ->
Interp
-> Message (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (EvalOpts
-> EvalExpr HValueRef
-> Message (EvalStatus_ [HValueRef] [HValueRef])
EvalStmt EvalOpts
opts EvalExpr HValueRef
expr)
handleEvalStatus interp status
where
withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr :: forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr (EvalThis ForeignHValue
fhv) EvalExpr HValueRef -> IO a
cont =
ForeignHValue -> (HValueRef -> IO a) -> IO a
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv ((HValueRef -> IO a) -> IO a) -> (HValueRef -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \HValueRef
hvref -> EvalExpr HValueRef -> IO a
cont (HValueRef -> EvalExpr HValueRef
forall a. a -> EvalExpr a
EvalThis HValueRef
hvref)
withExpr (EvalApp EvalExpr ForeignHValue
fl EvalExpr ForeignHValue
fr) EvalExpr HValueRef -> IO a
cont =
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
fl ((EvalExpr HValueRef -> IO a) -> IO a)
-> (EvalExpr HValueRef -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
fl' ->
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
fr ((EvalExpr HValueRef -> IO a) -> IO a)
-> (EvalExpr HValueRef -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
fr' ->
EvalExpr HValueRef -> IO a
cont (EvalExpr HValueRef -> EvalExpr HValueRef -> EvalExpr HValueRef
forall a. EvalExpr a -> EvalExpr a -> EvalExpr a
EvalApp EvalExpr HValueRef
fl' EvalExpr HValueRef
fr')
resumeStmt
:: Interp
-> EvalOpts
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt :: Interp
-> EvalOpts
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt Interp
interp EvalOpts
opts ForeignRef (ResumeContext [HValueRef])
resume_ctxt = do
status <- ForeignRef (ResumeContext [HValueRef])
-> (RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext [HValueRef])
resume_ctxt ((RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> (RemoteRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef]))
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext [HValueRef])
rhv ->
Interp
-> Message (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> Message (EvalStatus_ [HValueRef] [HValueRef])
ResumeStmt EvalOpts
opts RemoteRef (ResumeContext [HValueRef])
rhv)
handleEvalStatus interp status
abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt Interp
interp ForeignRef (ResumeContext [HValueRef])
resume_ctxt =
ForeignRef (ResumeContext [HValueRef])
-> (RemoteRef (ResumeContext [HValueRef]) -> IO ()) -> IO ()
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext [HValueRef])
resume_ctxt ((RemoteRef (ResumeContext [HValueRef]) -> IO ()) -> IO ())
-> (RemoteRef (ResumeContext [HValueRef]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext [HValueRef])
rhv ->
Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef (ResumeContext [HValueRef]) -> Message ()
AbandonStmt RemoteRef (ResumeContext [HValueRef])
rhv)
handleEvalStatus
:: Interp
-> EvalStatus [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus :: Interp
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus Interp
interp EvalStatus_ [HValueRef] [HValueRef]
status =
case EvalStatus_ [HValueRef] [HValueRef]
status of
EvalBreak HValueRef
a Maybe EvalBreakpoint
b RemoteRef (ResumeContext [HValueRef])
c RemotePtr CostCentreStack
d -> EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HValueRef
-> Maybe EvalBreakpoint
-> RemoteRef (ResumeContext [HValueRef])
-> RemotePtr CostCentreStack
-> EvalStatus_ [ForeignHValue] [HValueRef]
forall a b.
HValueRef
-> Maybe EvalBreakpoint
-> RemoteRef (ResumeContext b)
-> RemotePtr CostCentreStack
-> EvalStatus_ a b
EvalBreak HValueRef
a Maybe EvalBreakpoint
b RemoteRef (ResumeContext [HValueRef])
c RemotePtr CostCentreStack
d)
EvalComplete Word64
alloc EvalResult [HValueRef]
res ->
Word64
-> EvalResult [ForeignHValue]
-> EvalStatus_ [ForeignHValue] [HValueRef]
forall a b. Word64 -> EvalResult a -> EvalStatus_ a b
EvalComplete Word64
alloc (EvalResult [ForeignHValue]
-> EvalStatus_ [ForeignHValue] [HValueRef])
-> IO (EvalResult [ForeignHValue])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalResult [HValueRef] -> IO (EvalResult [ForeignHValue])
addFinalizer EvalResult [HValueRef]
res
where
addFinalizer :: EvalResult [HValueRef] -> IO (EvalResult [ForeignHValue])
addFinalizer (EvalException SerializableException
e) = EvalResult [ForeignHValue] -> IO (EvalResult [ForeignHValue])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SerializableException -> EvalResult [ForeignHValue]
forall a. SerializableException -> EvalResult a
EvalException SerializableException
e)
addFinalizer (EvalSuccess [HValueRef]
rs) =
[ForeignHValue] -> EvalResult [ForeignHValue]
forall a. a -> EvalResult a
EvalSuccess ([ForeignHValue] -> EvalResult [ForeignHValue])
-> IO [ForeignHValue] -> IO (EvalResult [ForeignHValue])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HValueRef -> IO ForeignHValue)
-> [HValueRef] -> IO [ForeignHValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Interp -> HValueRef -> IO ForeignHValue
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp) [HValueRef]
rs
evalIO :: Interp -> ForeignHValue -> IO ()
evalIO :: Interp -> ForeignHValue -> IO ()
evalIO Interp
interp ForeignHValue
fhv =
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> (HValueRef -> IO ()) -> IO ()
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv ((HValueRef -> IO ()) -> IO ()) -> (HValueRef -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
Interp -> Message (EvalResult ()) -> IO (EvalResult ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalResult ())
EvalIO HValueRef
fhv) IO (EvalResult ()) -> (EvalResult () -> 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
>>= EvalResult () -> IO ()
forall a. EvalResult a -> IO a
fromEvalResult
evalString :: Interp -> ForeignHValue -> IO String
evalString :: Interp -> ForeignHValue -> IO String
evalString Interp
interp ForeignHValue
fhv =
IO String -> IO String
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> (HValueRef -> IO String) -> IO String
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv ((HValueRef -> IO String) -> IO String)
-> (HValueRef -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
Interp -> Message (EvalResult String) -> IO (EvalResult String)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalResult String)
EvalString HValueRef
fhv) IO (EvalResult String)
-> (EvalResult String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EvalResult String -> IO String
forall a. EvalResult a -> IO a
fromEvalResult
evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String
evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String
evalStringToIOString Interp
interp ForeignHValue
fhv String
str =
IO String -> IO String
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> (HValueRef -> IO String) -> IO String
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv ((HValueRef -> IO String) -> IO String)
-> (HValueRef -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
Interp -> Message (EvalResult String) -> IO (EvalResult String)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> String -> Message (EvalResult String)
EvalStringToString HValueRef
fhv String
str) IO (EvalResult String)
-> (EvalResult String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EvalResult String -> IO String
forall a. EvalResult a -> IO a
fromEvalResult
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData Interp
interp ByteString
bs = Interp -> Message (RemotePtr ()) -> IO (RemotePtr ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (ByteString -> Message (RemotePtr ())
MallocData ByteString
bs)
mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
mkCostCentres :: Interp -> String -> [(String, String)] -> IO [RemotePtr CostCentre]
mkCostCentres Interp
interp String
mod [(String, String)]
ccs =
Interp
-> Message [RemotePtr CostCentre] -> IO [RemotePtr CostCentre]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> [(String, String)] -> Message [RemotePtr CostCentre]
MkCostCentres String
mod [(String, String)]
ccs)
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
createBCOs Interp
interp [ResolvedBCO]
rbcos = do
Interp -> Message [HValueRef] -> IO [HValueRef]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ResolvedBCO] -> Message [HValueRef]
CreateBCOs [ResolvedBCO]
rbcos)
addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry Interp
interp Fingerprint
fpr ForeignHValue
ref =
ForeignHValue -> (HValueRef -> IO ()) -> IO ()
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref ((HValueRef -> IO ()) -> IO ()) -> (HValueRef -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HValueRef
val ->
Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Fingerprint -> HValueRef -> Message ()
AddSptEntry Fingerprint
fpr HValueRef
val)
costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo Interp
interp RemotePtr CostCentreStack
ccs =
Interp -> Message [String] -> IO [String]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemotePtr CostCentreStack -> Message [String]
CostCentreStackInfo RemotePtr CostCentreStack
ccs)
newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
newBreakArray :: Interp -> BreakIndex -> IO (ForeignRef BreakArray)
newBreakArray Interp
interp BreakIndex
size = do
breakArray <- Interp
-> Message (RemoteRef BreakArray) -> IO (RemoteRef BreakArray)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (BreakIndex -> Message (RemoteRef BreakArray)
NewBreakArray BreakIndex
size)
mkFinalizedHValue interp breakArray
newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
newModuleName Interp
interp ModuleName
mod_name =
RemotePtr BreakModule -> RemotePtr ModuleName
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr (RemotePtr BreakModule -> RemotePtr ModuleName)
-> IO (RemotePtr BreakModule) -> IO (RemotePtr ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> Message (RemotePtr BreakModule) -> IO (RemotePtr BreakModule)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (RemotePtr BreakModule)
NewBreakModule (ModuleName -> String
moduleNameString ModuleName
mod_name))
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint :: Interp
-> ForeignRef BreakArray -> BreakIndex -> BreakIndex -> IO ()
storeBreakpoint Interp
interp ForeignRef BreakArray
ref BreakIndex
ix BreakIndex
cnt = do
ForeignRef BreakArray -> (RemoteRef BreakArray -> IO ()) -> IO ()
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
ref ((RemoteRef BreakArray -> IO ()) -> IO ())
-> (RemoteRef BreakArray -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RemoteRef BreakArray
breakarray ->
Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef BreakArray -> BreakIndex -> BreakIndex -> Message ()
SetupBreakpoint RemoteRef BreakArray
breakarray BreakIndex
ix BreakIndex
cnt)
breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus :: Interp -> ForeignRef BreakArray -> BreakIndex -> IO Bool
breakpointStatus Interp
interp ForeignRef BreakArray
ref BreakIndex
ix =
ForeignRef BreakArray
-> (RemoteRef BreakArray -> IO Bool) -> IO Bool
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
ref ((RemoteRef BreakArray -> IO Bool) -> IO Bool)
-> (RemoteRef BreakArray -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \RemoteRef BreakArray
breakarray ->
Interp -> Message Bool -> IO Bool
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef BreakArray -> BreakIndex -> Message Bool
BreakpointStatus RemoteRef BreakArray
breakarray BreakIndex
ix)
getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar :: Interp -> ForeignHValue -> BreakIndex -> IO (Maybe ForeignHValue)
getBreakpointVar Interp
interp ForeignHValue
ref BreakIndex
ix =
ForeignHValue
-> (HValueRef -> IO (Maybe ForeignHValue))
-> IO (Maybe ForeignHValue)
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref ((HValueRef -> IO (Maybe ForeignHValue))
-> IO (Maybe ForeignHValue))
-> (HValueRef -> IO (Maybe ForeignHValue))
-> IO (Maybe ForeignHValue)
forall a b. (a -> b) -> a -> b
$ \HValueRef
apStack -> do
mb <- Interp -> Message (Maybe HValueRef) -> IO (Maybe HValueRef)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> BreakIndex -> Message (Maybe HValueRef)
GetBreakpointVar HValueRef
apStack BreakIndex
ix)
mapM (mkFinalizedHValue interp) mb
getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
getClosure :: Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)
getClosure Interp
interp ForeignHValue
ref =
ForeignHValue
-> (HValueRef -> IO (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue)
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref ((HValueRef -> IO (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue))
-> (HValueRef -> IO (GenClosure ForeignHValue))
-> IO (GenClosure ForeignHValue)
forall a b. (a -> b) -> a -> b
$ \HValueRef
hval -> do
mb <- Interp
-> Message (GenClosure HValueRef) -> IO (GenClosure HValueRef)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (GenClosure HValueRef)
GetClosure HValueRef
hval)
mapM (mkFinalizedHValue interp) mb
seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue Interp
interp UnitEnv
unit_env ForeignHValue
ref =
ForeignHValue
-> (HValueRef -> IO (EvalResult ())) -> IO (EvalResult ())
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref ((HValueRef -> IO (EvalResult ())) -> IO (EvalResult ()))
-> (HValueRef -> IO (EvalResult ())) -> IO (EvalResult ())
forall a b. (a -> b) -> a -> b
$ \HValueRef
hval -> do
status <- Interp -> Message (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalStatus_ () ())
Seq HValueRef
hval)
handleSeqHValueStatus interp unit_env status
evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId HomePackageTable
hpt EvalBreakpoint
eval_break =
let load_mod :: String -> Module
load_mod String
x = ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface_ 'ModIfaceFinal -> Module)
-> ModIface_ 'ModIfaceFinal -> Module
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo -> ModIface_ 'ModIfaceFinal
forall a b. (a -> b) -> a -> b
$ String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"evalBreakpointToId" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (String -> ModuleName
mkModuleName String
x)
in InternalBreakpointId
{ ibi_tick_mod :: Module
ibi_tick_mod = String -> Module
load_mod (EvalBreakpoint -> String
eb_tick_mod EvalBreakpoint
eval_break)
, ibi_tick_index :: BreakIndex
ibi_tick_index = EvalBreakpoint -> BreakIndex
eb_tick_index EvalBreakpoint
eval_break
, ibi_info_mod :: Module
ibi_info_mod = String -> Module
load_mod (EvalBreakpoint -> String
eb_info_mod EvalBreakpoint
eval_break)
, ibi_info_index :: BreakIndex
ibi_info_index = EvalBreakpoint -> BreakIndex
eb_info_index EvalBreakpoint
eval_break
}
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp UnitEnv
unit_env EvalStatus_ () ()
eval_status =
case EvalStatus_ () ()
eval_status of
(EvalBreak HValueRef
_ Maybe EvalBreakpoint
maybe_break RemoteRef (ResumeContext ())
resume_ctxt RemotePtr CostCentreStack
_) -> do
resume_ctxt_fhv <- IO (ForeignRef (ResumeContext ()))
-> IO (ForeignRef (ResumeContext ()))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignRef (ResumeContext ()))
-> IO (ForeignRef (ResumeContext ())))
-> IO (ForeignRef (ResumeContext ()))
-> IO (ForeignRef (ResumeContext ()))
forall a b. (a -> b) -> a -> b
$ Interp
-> RemoteRef (ResumeContext ())
-> IO (ForeignRef (ResumeContext ()))
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext ())
resume_ctxt
let bp = HomePackageTable -> EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId (HasDebugCallStack => UnitEnv -> HomePackageTable
UnitEnv -> HomePackageTable
ue_hpt UnitEnv
unit_env) (EvalBreakpoint -> InternalBreakpointId)
-> Maybe EvalBreakpoint -> Maybe InternalBreakpointId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EvalBreakpoint
maybe_break
sdocBpLoc = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc)
-> (Maybe InternalBreakpointId -> SDoc)
-> Maybe InternalBreakpointId
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc)
-> (Maybe InternalBreakpointId -> SrcSpan)
-> Maybe InternalBreakpointId
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe InternalBreakpointId -> SrcSpan
getSeqBpSpan
putStrLn ("*** Ignoring breakpoint " ++
(showSDocUnsafe $ sdocBpLoc bp))
withForeignRef resume_ctxt_fhv $ \RemoteRef (ResumeContext ())
hval -> do
status <- Interp -> Message (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef (ResumeContext ()) -> Message (EvalStatus_ () ())
ResumeSeq RemoteRef (ResumeContext ())
hval)
handleSeqHValueStatus interp unit_env status
(EvalComplete Word64
_ EvalResult ()
r) -> EvalResult () -> IO (EvalResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EvalResult ()
r
where
getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan
getSeqBpSpan :: Maybe InternalBreakpointId -> SrcSpan
getSeqBpSpan = \case
Just InternalBreakpointId
bi -> (ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs (Module -> ModBreaks
breaks (InternalBreakpointId -> Module
ibi_tick_mod InternalBreakpointId
bi))) Array BreakIndex SrcSpan -> BreakIndex -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! InternalBreakpointId -> BreakIndex
ibi_tick_index InternalBreakpointId
bi
Maybe InternalBreakpointId
Nothing -> FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"<unknown>")
breaks :: Module -> ModBreaks
breaks Module
mod = HomeModInfo -> ModBreaks
getModBreaks (HomeModInfo -> ModBreaks) -> HomeModInfo -> ModBreaks
forall a b. (a -> b) -> a -> b
$ String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"getSeqBpSpan" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HasDebugCallStack => UnitEnv -> HomePackageTable
UnitEnv -> HomePackageTable
ue_hpt UnitEnv
unit_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
initObjLinker :: Interp -> IO ()
initObjLinker :: Interp -> IO ()
initObjLinker Interp
interp = Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp Message ()
InitLinker
lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
str = Interp -> FastString -> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
withSymbolCache Interp
interp FastString
str (IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$
case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> (RemotePtr () -> Ptr ()) -> Maybe (RemotePtr ()) -> Maybe (Ptr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (Maybe (RemotePtr ()) -> Maybe (Ptr ()))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. Message a -> IO a
run (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
#endif
ExternalInterp ExtInterp
ext -> case ExtInterp
ext of
ExtIServ IServ
i -> IServ
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall (m :: * -> *) a.
ExceptionMonad m =>
IServ -> (ExtInterpInstance () -> m a) -> m a
withIServ IServ
i ((ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ())))
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$ \ExtInterpInstance ()
inst -> (RemotePtr () -> Ptr ()) -> Maybe (RemotePtr ()) -> Maybe (Ptr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (Maybe (RemotePtr ()) -> Maybe (Ptr ()))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. IO a -> IO a
uninterruptibleMask_ (IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ())))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a b. (a -> b) -> a -> b
$
ExtInterpInstance ()
-> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance ()
inst (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
ExtJS {} -> String -> SDoc -> IO (Maybe (Ptr ()))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupSymbol not supported by the JS interpreter" (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
str)
ExtWasm WasmInterp
i -> WasmInterp
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall (m :: * -> *) a.
ExceptionMonad m =>
WasmInterp -> (ExtInterpInstance () -> m a) -> m a
withWasmInterp WasmInterp
i ((ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ())))
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$ \ExtInterpInstance ()
inst -> (RemotePtr () -> Ptr ()) -> Maybe (RemotePtr ()) -> Maybe (Ptr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (Maybe (RemotePtr ()) -> Maybe (Ptr ()))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. IO a -> IO a
uninterruptibleMask_ (IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ())))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a b. (a -> b) -> a -> b
$
ExtInterpInstance ()
-> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance ()
inst (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
lookupSymbolInDLL Interp
interp RemotePtr LoadedDLL
dll FastString
str = Interp -> FastString -> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
withSymbolCache Interp
interp FastString
str (IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$
case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> (RemotePtr () -> Ptr ()) -> Maybe (RemotePtr ()) -> Maybe (Ptr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (Maybe (RemotePtr ()) -> Maybe (Ptr ()))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. Message a -> IO a
run (RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
LookupSymbolInDLL RemotePtr LoadedDLL
dll (FastString -> String
unpackFS FastString
str))
#endif
ExternalInterp ExtInterp
ext -> case ExtInterp
ext of
ExtIServ IServ
i -> IServ
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall (m :: * -> *) a.
ExceptionMonad m =>
IServ -> (ExtInterpInstance () -> m a) -> m a
withIServ IServ
i ((ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ())))
-> (ExtInterpInstance () -> IO (Maybe (Ptr ())))
-> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$ \ExtInterpInstance ()
inst -> (RemotePtr () -> Ptr ()) -> Maybe (RemotePtr ()) -> Maybe (Ptr ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (Maybe (RemotePtr ()) -> Maybe (Ptr ()))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (Ptr ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. IO a -> IO a
uninterruptibleMask_ (IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ())))
-> IO (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a b. (a -> b) -> a -> b
$
ExtInterpInstance ()
-> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance ()
inst (RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
LookupSymbolInDLL RemotePtr LoadedDLL
dll (FastString -> String
unpackFS FastString
str))
ExtJS {} -> String -> SDoc -> IO (Maybe (Ptr ()))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupSymbol not supported by the JS interpreter" (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
str)
ExtWasm {} -> Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
str
lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure Interp
interp String
str =
Interp -> Message (Maybe HValueRef) -> IO (Maybe HValueRef)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (Maybe HValueRef)
LookupClosure String
str)
withSymbolCache :: Interp
-> FastString
-> IO (Maybe (Ptr ()))
-> IO (Maybe (Ptr ()))
withSymbolCache :: Interp -> FastString -> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
withSymbolCache Interp
interp FastString
str IO (Maybe (Ptr ()))
determine_addr = do
cache <- MVar (UniqFM FastString (Ptr ()))
-> IO (UniqFM FastString (Ptr ()))
forall a. MVar a -> IO a
readMVar (Interp -> MVar (UniqFM FastString (Ptr ()))
interpLookupSymbolCache Interp
interp)
case lookupUFM cache str of
Just Ptr ()
p -> Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
p)
Maybe (Ptr ())
Nothing -> do
maddr <- IO (Maybe (Ptr ()))
determine_addr
case maddr of
Maybe (Ptr ())
Nothing -> Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr ())
forall a. Maybe a
Nothing
Just Ptr ()
p -> do
let upd_cache :: UniqFM FastString (Ptr ()) -> UniqFM FastString (Ptr ())
upd_cache UniqFM FastString (Ptr ())
cache' = UniqFM FastString (Ptr ())
-> FastString -> Ptr () -> UniqFM FastString (Ptr ())
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM FastString (Ptr ())
cache' FastString
str Ptr ()
p
MVar (UniqFM FastString (Ptr ()))
-> (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ())))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Interp -> MVar (UniqFM FastString (Ptr ()))
interpLookupSymbolCache Interp
interp) (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ())))
-> (UniqFM FastString (Ptr ()) -> UniqFM FastString (Ptr ()))
-> UniqFM FastString (Ptr ())
-> IO (UniqFM FastString (Ptr ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqFM FastString (Ptr ()) -> UniqFM FastString (Ptr ())
upd_cache)
Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
p)
purgeLookupSymbolCache :: Interp -> IO ()
purgeLookupSymbolCache :: Interp -> IO ()
purgeLookupSymbolCache Interp
interp = MVar (UniqFM FastString (Ptr ()))
-> (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ())))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Interp -> MVar (UniqFM FastString (Ptr ()))
interpLookupSymbolCache Interp
interp) (IO (UniqFM FastString (Ptr ()))
-> UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ()))
forall a b. a -> b -> a
const (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UniqFM FastString (Ptr ())
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM))
loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL))
loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL))
loadDLL Interp
interp String
str = Interp
-> Message (Either String (RemotePtr LoadedDLL))
-> IO (Either String (RemotePtr LoadedDLL))
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (Either String (RemotePtr LoadedDLL))
LoadDLL String
str)
loadArchive :: Interp -> String -> IO ()
loadArchive :: Interp -> String -> IO ()
loadArchive Interp
interp String
path = do
path' <- String -> IO String
canonicalizePath String
path
interpCmd interp (LoadArchive path')
loadObj :: Interp -> String -> IO ()
loadObj :: Interp -> String -> IO ()
loadObj Interp
interp String
path = do
path' <- String -> IO String
canonicalizePath String
path
interpCmd interp (LoadObj path')
unloadObj :: Interp -> String -> IO ()
unloadObj :: Interp -> String -> IO ()
unloadObj Interp
interp String
path = do
path' <- String -> IO String
canonicalizePath String
path
interpCmd interp (UnloadObj path')
addLibrarySearchPath :: Interp -> String -> IO (Ptr ())
addLibrarySearchPath :: Interp -> String -> IO (Ptr ())
addLibrarySearchPath Interp
interp String
str =
RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (RemotePtr () -> Ptr ()) -> IO (RemotePtr ()) -> IO (Ptr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp -> Message (RemotePtr ()) -> IO (RemotePtr ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (RemotePtr ())
AddLibrarySearchPath String
str)
removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool
removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool
removeLibrarySearchPath Interp
interp Ptr ()
p =
Interp -> Message Bool -> IO Bool
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemotePtr () -> Message Bool
RemoveLibrarySearchPath (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))
resolveObjs :: Interp -> IO SuccessFlag
resolveObjs :: Interp -> IO SuccessFlag
resolveObjs Interp
interp = Bool -> SuccessFlag
successIf (Bool -> SuccessFlag) -> IO Bool -> IO SuccessFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp -> Message Bool -> IO Bool
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp Message Bool
ResolveObjs
findSystemLibrary :: Interp -> String -> IO (Maybe String)
findSystemLibrary :: Interp -> String -> IO (Maybe String)
findSystemLibrary Interp
interp String
str = Interp -> Message (Maybe String) -> IO (Maybe String)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (Maybe String)
FindSystemLibrary String
str)
spawnIServ :: IServConfig -> IO (ExtInterpInstance ())
spawnIServ :: IServConfig -> IO (ExtInterpInstance ())
spawnIServ IServConfig
conf = do
IServConfig -> IO ()
iservConfTrace IServConfig
conf
let createProc :: CreateProcess -> IO ProcessHandle
createProc = (CreateProcess -> IO ProcessHandle)
-> Maybe (CreateProcess -> IO ProcessHandle)
-> CreateProcess
-> IO ProcessHandle
forall a. a -> Maybe a -> a
fromMaybe (\CreateProcess
cp -> do { (_,_,_,ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
; return ph })
(IServConfig -> Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook IServConfig
conf)
(ph, rh, wh) <- (CreateProcess -> IO ProcessHandle)
-> String
-> [String]
-> [String]
-> IO (ProcessHandle, Handle, Handle)
runWithPipes CreateProcess -> IO ProcessHandle
createProc (IServConfig -> String
iservConfProgram IServConfig
conf)
[]
(IServConfig -> [String]
iservConfOpts IServConfig
conf)
lo_ref <- newIORef Nothing
lock <- newMVar ()
let pipe = Pipe { pipeRead :: Handle
pipeRead = Handle
rh, pipeWrite :: Handle
pipeWrite = Handle
wh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref }
let process = InterpProcess
{ interpHandle :: ProcessHandle
interpHandle = ProcessHandle
ph
, interpPipe :: Pipe
interpPipe = Pipe
pipe
, interpLock :: MVar ()
interpLock = MVar ()
lock
}
pending_frees <- newMVar []
let inst = ExtInterpInstance
{ instProcess :: InterpProcess
instProcess = InterpProcess
process
, instPendingFrees :: MVar [HValueRef]
instPendingFrees = MVar [HValueRef]
pending_frees
, instExtra :: ()
instExtra = ()
}
pure inst
stopInterp :: Interp -> IO ()
stopInterp :: Interp -> IO ()
stopInterp Interp
interp = case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
ExternalInterp ExtInterp
ext -> ExtInterp -> (forall d. ExtInterpStatusVar d -> IO ()) -> IO ()
forall {k} (m :: k -> *) (a :: k).
ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
withExtInterpStatus ExtInterp
ext ((forall d. ExtInterpStatusVar d -> IO ()) -> IO ())
-> (forall d. ExtInterpStatusVar d -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ExtInterpStatusVar d
mstate -> do
((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_restore -> ExtInterpStatusVar d
-> (InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ExtInterpStatusVar d
mstate ((InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d)))
-> IO ())
-> (InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \InterpStatus (ExtInterpInstance d)
state -> do
case InterpStatus (ExtInterpInstance d)
state of
InterpStatus (ExtInterpInstance d)
InterpPending -> InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpStatus (ExtInterpInstance d)
state
InterpRunning ExtInterpInstance d
i -> do
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode (InterpProcess -> ProcessHandle
interpHandle (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i))
if isJust ex
then pure ()
else sendMessage i Shutdown
pure InterpPending
mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue :: forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef a
rref = do
case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> RemoteRef a -> IO () -> IO (ForeignRef a)
forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef RemoteRef a
rref (RemoteRef a -> IO ()
forall a. RemoteRef a -> IO ()
freeRemoteRef RemoteRef a
rref)
#endif
ExternalInterp ExtInterp
ext -> ExtInterp
-> (forall d. Maybe (ExtInterpInstance d) -> IO (ForeignRef a))
-> IO (ForeignRef a)
forall (m :: * -> *) a.
ExceptionMonad m =>
ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a
withExtInterpMaybe ExtInterp
ext ((forall d. Maybe (ExtInterpInstance d) -> IO (ForeignRef a))
-> IO (ForeignRef a))
-> (forall d. Maybe (ExtInterpInstance d) -> IO (ForeignRef a))
-> IO (ForeignRef a)
forall a b. (a -> b) -> a -> b
$ \case
Maybe (ExtInterpInstance d)
Nothing -> RemoteRef a -> IO () -> IO (ForeignRef a)
forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef RemoteRef a
rref (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Just ExtInterpInstance d
inst -> RemoteRef a -> IO () -> IO (ForeignRef a)
forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef RemoteRef a
rref (ExtInterpInstance d -> RemoteRef a -> IO ()
forall d a. ExtInterpInstance d -> RemoteRef a -> IO ()
freeReallyRemoteRef ExtInterpInstance d
inst RemoteRef a
rref)
freeReallyRemoteRef :: ExtInterpInstance d -> RemoteRef a -> IO ()
freeReallyRemoteRef :: forall d a. ExtInterpInstance d -> RemoteRef a -> IO ()
freeReallyRemoteRef ExtInterpInstance d
inst RemoteRef a
rref =
MVar [HValueRef] -> ([HValueRef] -> IO [HValueRef]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (ExtInterpInstance d -> MVar [HValueRef]
forall c. ExtInterpInstance c -> MVar [HValueRef]
instPendingFrees ExtInterpInstance d
inst) (\[HValueRef]
xs -> [HValueRef] -> IO [HValueRef]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteRef a -> HValueRef
forall a b. RemoteRef a -> RemoteRef b
castRemoteRef RemoteRef a
rref HValueRef -> [HValueRef] -> [HValueRef]
forall a. a -> [a] -> [a]
: [HValueRef]
xs))
freeHValueRefs :: Interp -> [HValueRef] -> IO ()
freeHValueRefs :: Interp -> [HValueRef] -> IO ()
freeHValueRefs Interp
_ [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeHValueRefs Interp
interp [HValueRef]
refs = Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([HValueRef] -> Message ()
FreeHValueRefs [HValueRef]
refs)
wormhole :: Interp -> ForeignRef a -> IO a
wormhole :: forall a. Interp -> ForeignRef a -> IO a
wormhole Interp
interp ForeignRef a
r = Interp -> RemoteRef a -> IO a
forall a. Interp -> RemoteRef a -> IO a
wormholeRef Interp
interp (ForeignRef a -> RemoteRef a
forall a. ForeignRef a -> RemoteRef a
unsafeForeignRefToRemoteRef ForeignRef a
r)
wormholeRef :: Interp -> RemoteRef a -> IO a
wormholeRef :: forall a. Interp -> RemoteRef a -> IO a
wormholeRef Interp
interp RemoteRef a
_r = case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> RemoteRef a -> IO a
forall a. RemoteRef a -> IO a
localRef RemoteRef a
_r
#endif
ExternalInterp {}
-> GhcException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> GhcException
InstallationError String
"this operation requires -fno-external-interpreter")
fromEvalResult :: EvalResult a -> IO a
fromEvalResult :: forall a. EvalResult a -> IO a
fromEvalResult (EvalException SerializableException
e) = SomeException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
fromEvalResult (EvalSuccess a
a) = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
| Just Linkable
linkable <- HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi,
[CompiledByteCode
cbc] <- Linkable -> [CompiledByteCode]
linkableBCOs Linkable
linkable
= ModBreaks -> Maybe ModBreaks -> ModBreaks
forall a. a -> Maybe a -> a
fromMaybe ModBreaks
emptyModBreaks (CompiledByteCode -> Maybe ModBreaks
bc_breaks CompiledByteCode
cbc)
| Bool
otherwise
= ModBreaks
emptyModBreaks
interpreterProfiled :: Interp -> Bool
interpreterProfiled :: Interp -> Bool
interpreterProfiled Interp
interp = case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> Bool
hostIsProfiled
#endif
ExternalInterp ExtInterp
ext -> case ExtInterp
ext of
ExtIServ IServ
i -> IServConfig -> Bool
iservConfProfiled (IServ -> IServConfig
forall cfg details. ExtInterpState cfg details -> cfg
interpConfig IServ
i)
ExtJS {} -> Bool
False
ExtWasm WasmInterp
i -> WasmInterpConfig -> Bool
wasmInterpProfiled (WasmInterpConfig -> Bool) -> WasmInterpConfig -> Bool
forall a b. (a -> b) -> a -> b
$ WasmInterp -> WasmInterpConfig
forall cfg details. ExtInterpState cfg details -> cfg
interpConfig WasmInterp
i
interpreterDynamic :: Interp -> Bool
interpreterDynamic :: Interp -> Bool
interpreterDynamic Interp
interp = case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InterpInstance
InternalInterp -> Bool
hostIsDynamic
#endif
ExternalInterp ExtInterp
ext -> case ExtInterp
ext of
ExtIServ IServ
i -> IServConfig -> Bool
iservConfDynamic (IServ -> IServConfig
forall cfg details. ExtInterpState cfg details -> cfg
interpConfig IServ
i)
ExtJS {} -> Bool
False
ExtWasm {} -> Bool
True