{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}

-- | Interacting with the iserv interpreter, whether it is running on an
-- external process or in the current process.
--
module GHC.Runtime.Interpreter
  ( module GHC.Runtime.Interpreter.Types

  -- * High-level interface to the interpreter
  , 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

  -- * The object-code linker
  , 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

  -- * Reexport for convenience
  , Message (..)
  , module GHC.Runtime.Interpreter.Process
  ) where

import GHC.Prelude

import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Interpreter.JS
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

{- Note [Remote GHCi]
   ~~~~~~~~~~~~~~~~~~
When the flag -fexternal-interpreter is given to GHC, interpreted code
is run in a separate process called iserv, and we communicate with the
external process over a pipe using Binary-encoded messages.

Motivation
~~~~~~~~~~

When the interpreted code is running in a separate process, it can
use a different "way", e.g. profiled or dynamic.  This means

- compiling Template Haskell code with -prof does not require
  building the code without -prof first

- when GHC itself is profiled, it can interpret unprofiled code,
  and the same applies to dynamic linking.

- An unprofiled GHCi can load and run profiled code, which means it
  can use the stack-trace functionality provided by profiling without
  taking the performance hit on the compiler that profiling would
  entail.

For other reasons see remote-GHCi on the wiki.

Implementation Overview
~~~~~~~~~~~~~~~~~~~~~~~

The main pieces are:

- libraries/ghci, containing:
  - types for talking about remote values (GHCi.RemoteTypes)
  - the message protocol (GHCi.Message),
  - implementation of the messages (GHCi.Run)
  - implementation of Template Haskell (GHCi.TH)
  - a few other things needed to run interpreted code

- top-level iserv directory, containing the code for the external
  server. This is a fairly simple wrapper, most of the functionality
  is provided by modules in libraries/ghci.

- This module which provides the interface to the server used
  by the rest of GHC.

GHC works with and without -fexternal-interpreter. With the flag, all
interpreted code is run by the iserv binary. Without the flag,
interpreted code is run in the same process as GHC.

Things that do not work with -fexternal-interpreter
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

dynCompileExpr cannot work, because we have no way to run code of an
unknown type in the remote process. This API fails with an error
message if it is used with -fexternal-interpreter.

Other Notes on Remote GHCi
~~~~~~~~~~~~~~~~~~~~~~~~~~
  * This wiki page has an implementation overview:
    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter
  * Note [External GHCi pointers] in "GHC.Runtime.Interpreter"
  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
-}


-- | Run a command in the interpreter's context.  With
-- @-fexternal-interpreter@, the command is serialized and sent to an
-- external iserv process, and the response is deserialized (hence the
-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute
-- the command directly here.
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 -- Just run it directly
#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
$ -- Note [uninterruptibleMask_ and interpCmd]
      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
  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)
  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)

-- Note [uninterruptibleMask_ and interpCmd]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- If we receive an async exception, such as ^C, while communicating
-- with the iserv process then we will be out-of-sync and not be able
-- to recover.  Thus we use uninterruptibleMask_ during
-- communication.  A ^C will be delivered to the iserv process (because
-- signals get sent to the whole process group) which will interrupt
-- the running computation and return an EvalException result.

-- | Grab a lock on the 'IServ' and do something with it.
-- Overloaded because this is used from TcM as well as IO.
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

-- | Spawn JS interpreter if it isn't already running and execute the given action
--
-- Update the interpreter state.
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

-- | Spawn an interpreter if not already running according to the status in the
-- MVar. Update the status, free pending heap references, and return the
-- interpreter instance.
--
-- This function is generic to support both the native external interpreter and
-- the JS one.
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
    -- start the external iserv process if we haven't done so yet
    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)

  -- free any ForeignRef that have been garbage collected.
  pending_frees <- liftIO $ swapMVar (instPendingFrees inst) []
  liftIO $ when (not (null (pending_frees))) $
    sendMessage inst (FreeHValueRefs pending_frees)

  -- run the inner action
  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 -- already shut down or never launched
    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)

-- -----------------------------------------------------------------------------
-- Wrappers around messages

-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
-- each of the results.
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

-- | Execute an action of type @IO ()@
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

-- | Execute an action of type @IO String@
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

-- | Execute an action of type @String -> IO String@
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


-- | Allocate and store the given bytes in memory, returning a pointer
-- to the memory in the remote process.
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)

-- | Create a set of BCOs that may be mutually recursive.
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                               -- #19157
  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

-- | Send a Seq message to the iserv process to force a value      #2950
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
        }

-- | Process the result of a Seq or ResumeSeq message.             #2950
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
      -- A breakpoint was hit; inform the user and tell them
      -- which breakpoint was hit.
      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))
      -- resume the seq (:force) processing in the iserv process
      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
        -- Just case: Stopped at a breakpoint, extract SrcSpan information
        -- from the breakpoint.
      Maybe InternalBreakpointId
Nothing -> FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"<unknown>")
        -- Nothing case - should not occur!
        -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
        --
    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)


-- -----------------------------------------------------------------------------
-- Interface to the object-code linker

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)

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)

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' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
-- When there's a cache hit we simply return the cached address, when there is
-- a miss we run the action which determines the symbol's address and populate
-- the cache with the answer.
withSymbolCache :: Interp
                -> FastString
                -- ^ The symbol we are looking up in the cache
                -> IO (Maybe (Ptr ()))
                -- ^ An action which determines the address of the symbol we
                -- are looking up in the cache, which is run if there is a
                -- cache miss. The result will be cached.
                -> IO (Maybe (Ptr ()))
withSymbolCache :: Interp -> FastString -> IO (Maybe (Ptr ())) -> IO (Maybe (Ptr ()))
withSymbolCache Interp
interp FastString
str IO (Maybe (Ptr ()))
determine_addr = do

  -- Profiling of GHCi showed a lot of time and allocation spent
  -- making cross-process LookupSymbol calls, so I added a GHC-side
  -- cache which sped things up quite a lot. We have to be careful
  -- to purge this cache when unloading code though.
  --
  -- The analysis in #23415 further showed this cache should also benefit the
  -- internal interpreter's loading times, and needn't be used by the external
  -- interpreter only.
  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 loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
-- an absolute pathname to the file, or a relative filename
-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
-- searches the standard locations for the appropriate library.
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 -- Note [loadObj and relative paths]
  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 -- Note [loadObj and relative paths]
  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 -- Note [loadObj and relative paths]
  interpCmd interp (UnloadObj path')

-- Note [loadObj and relative paths]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- the iserv process might have a different current directory from the
-- GHC process, so we must make paths absolute before sending them
-- over.

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)

-- -----------------------------------------------------------------------------
-- IServ specific calls and messages

-- | Spawn an external interpreter
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
  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
                  }

  pending_frees <- newMVar []
  let inst = ExtInterpInstance
        { instProcess :: InterpProcess
instProcess           = InterpProcess
process
        , instPendingFrees :: MVar [HValueRef]
instPendingFrees      = MVar [HValueRef]
pending_frees
        , instExtra :: ()
instExtra             = ()
        }
  pure inst

-- | Stop the interpreter
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 -- already stopped
          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

-- -----------------------------------------------------------------------------
{- Note [External GHCi pointers]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have the following ways to reference things in GHCi:

HValue
------

HValue is a direct reference to a value in the local heap.  Obviously
we cannot use this to refer to things in the external process.


RemoteRef
---------

RemoteRef is a StablePtr to a heap-resident value.  When -fexternal-interpreter
or the JS interpreter is used, this value resides in the external process's
heap. RemoteRefs are mostly used to send pointers in messages between GHC and
iserv.

A RemoteRef must be explicitly freed when no longer required, using
freeHValueRefs, or by attaching a finalizer with mkForeignHValue.

To get from a RemoteRef to an HValue you can use 'wormholeRef', which
fails with an error message if -fexternal-interpreter is in use.

ForeignRef
----------

A ForeignRef is a RemoteRef with a finalizer that will free the
'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue
on the GHC side.

The finalizer adds the RemoteRef to the iservPendingFrees list in the
IServ record.  The next call to interpCmd will free any RemoteRefs in
the list.  It was done this way rather than calling interpCmd directly,
because I didn't want to have arbitrary threads calling interpCmd.  In
principle it would probably be ok, but it seems less hairy this way.
-}

-- | Creates a 'ForeignRef' that will automatically release the
-- 'RemoteRef' when it is no longer referenced.
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 ()) -- nothing to do, interpreter already stopped
      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 =
  -- add to the list of HValues to free
  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)

-- | Convert a 'ForeignRef' to the value it references directly.  This
-- only works when the interpreter is running in the same process as
-- the compiler, so it fails when @-fexternal-interpreter@ is on.
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)

-- | Convert an 'RemoteRef' to the value it references directly.  This
-- only works when the interpreter is running in the same process as
-- the compiler, so it fails when @-fexternal-interpreter@ is on.
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")

-- -----------------------------------------------------------------------------
-- Misc utils

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,
    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
    [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 -- probably object code

-- | Interpreter uses Profiling way
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 -- we don't support profiling yet in the JS backend

-- | Interpreter uses Dynamic way
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 -- dynamic doesn't make sense for JS