{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-- | 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
  , storeBreakpoint
  , breakpointStatus
  , getBreakpointVar
  , getClosure
  , getModBreaks
  , seqHValue
  , interpreterDynamic
  , interpreterProfiled

  -- * The object-code linker
  , initObjLinker
  , lookupSymbol
  , 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.BreakInfo (BreakInfo(..))
import GHC.ByteCode.Types

import GHC.Linker.Types

import GHC.Data.Maybe
import GHC.Data.FastString

import GHC.Types.Unique
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.Utils.Misc

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.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
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
import GHC.Conc (pseq, par)

{- 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 codefor 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 (m :: * -> *) a.
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
  ExtInterpInstance ()
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
  ExtInterpInstance () -> m a
action ExtInterpInstance ()
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
  ExtInterpInstance JSInterpExtra
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
  ExtInterpInstance JSInterpExtra -> m a
action ExtInterpInstance JSInterpExtra
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
  ExtInterpInstance d
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
      ExtInterpInstance d
inst <- cfg -> IO (ExtInterpInstance d)
spawn cfg
cfg
      (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)

    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.
  [HValueRef]
pending_frees <- IO [HValueRef] -> m [HValueRef]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HValueRef] -> m [HValueRef])
-> IO [HValueRef] -> m [HValueRef]
forall a b. (a -> b) -> a -> b
$ MVar [HValueRef] -> [HValueRef] -> IO [HValueRef]
forall a. MVar a -> a -> IO a
swapMVar (ExtInterpInstance d -> MVar [HValueRef]
forall c. ExtInterpInstance c -> MVar [HValueRef]
instPendingFrees ExtInterpInstance d
inst) []
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([HValueRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([HValueRef]
pending_frees))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    ExtInterpInstance d -> Message () -> IO ()
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
inst ([HValueRef] -> Message ()
FreeHValueRefs [HValueRef]
pending_frees)

  -- run the inner action
  ExtInterpInstance d -> m (ExtInterpInstance d)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtInterpInstance d
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 (m :: * -> *) a.
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 Any) -> m a
forall d. Maybe (ExtInterpInstance d) -> m a
action Maybe (ExtInterpInstance Any)
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
  EvalStatus_ [HValueRef] [HValueRef]
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)
  Interp
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus Interp
interp EvalStatus_ [HValueRef] [HValueRef]
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
  EvalStatus_ [HValueRef] [HValueRef]
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)
  Interp
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus Interp
interp EvalStatus_ [HValueRef] [HValueRef]
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 Bool
a HValueRef
b BreakIndex
c BreakIndex
d RemoteRef (ResumeContext [HValueRef])
e RemotePtr CostCentreStack
f -> EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
-> HValueRef
-> BreakIndex
-> BreakIndex
-> RemoteRef (ResumeContext [HValueRef])
-> RemotePtr CostCentreStack
-> EvalStatus_ [ForeignHValue] [HValueRef]
forall a b.
Bool
-> HValueRef
-> BreakIndex
-> BreakIndex
-> RemoteRef (ResumeContext b)
-> RemotePtr CostCentreStack
-> EvalStatus_ a b
EvalBreak Bool
a HValueRef
b BreakIndex
c BreakIndex
d RemoteRef (ResumeContext [HValueRef])
e RemotePtr CostCentreStack
f)
    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
  -- Serializing ResolvedBCO is expensive, so we do it in parallel
  Interp -> Message [HValueRef] -> IO [HValueRef]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [HValueRef]
CreateBCOs [ByteString]
puts)
 where
  puts :: [ByteString]
puts = ([ResolvedBCO] -> ByteString) -> [[ResolvedBCO]] -> [ByteString]
forall {t} {a}. (t -> a) -> [t] -> [a]
parMap [ResolvedBCO] -> ByteString
forall {t}. Binary t => t -> ByteString
doChunk (BreakIndex -> [ResolvedBCO] -> [[ResolvedBCO]]
forall a. BreakIndex -> [a] -> [[a]]
chunkList BreakIndex
100 [ResolvedBCO]
rbcos)

  -- make sure we force the whole lazy ByteString
  doChunk :: t -> ByteString
doChunk t
c = Int64 -> ByteString -> ByteString
forall a b. a -> b -> b
pseq (ByteString -> Int64
LB.length ByteString
bs) ByteString
bs
    where bs :: ByteString
bs = Put -> ByteString
runPut (t -> Put
forall t. Binary t => t -> Put
put t
c)

  -- We don't have the parallel package, so roll our own simple parMap
  parMap :: (t -> a) -> [t] -> [a]
parMap t -> a
_ [] = []
  parMap t -> a
f (t
x:[t]
xs) = a
fx a -> [a] -> [a]
forall a b. a -> b -> b
`par` ([a]
fxs [a] -> [a] -> [a]
forall a b. a -> b -> b
`pseq` (a
fx a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
fxs))
    where fx :: a
fx = t -> a
f t
x; fxs :: [a]
fxs = (t -> a) -> [t] -> [a]
parMap t -> a
f [t]
xs

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
  RemoteRef BreakArray
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)
  Interp -> RemoteRef BreakArray -> IO (ForeignRef BreakArray)
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef BreakArray
breakArray

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
    Maybe HValueRef
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)
    (HValueRef -> IO ForeignHValue)
-> Maybe HValueRef -> IO (Maybe 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) -> Maybe a -> m (Maybe b)
mapM (Interp -> HValueRef -> IO ForeignHValue
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp) Maybe HValueRef
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
    GenClosure HValueRef
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)
    (HValueRef -> IO ForeignHValue)
-> GenClosure HValueRef -> IO (GenClosure 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) -> GenClosure a -> m (GenClosure b)
mapM (Interp -> HValueRef -> IO ForeignHValue
forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp) GenClosure HValueRef
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
    EvalStatus_ () ()
status <- Interp -> Message (EvalStatus_ () ()) -> IO (EvalStatus_ () ())
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalStatus_ () ())
Seq HValueRef
hval)
    Interp -> UnitEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp UnitEnv
unit_env EvalStatus_ () ()
status

-- | 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 Bool
is_exception HValueRef
_ BreakIndex
ix BreakIndex
mod_uniq RemoteRef (ResumeContext ())
resume_ctxt RemotePtr CostCentreStack
_) -> do
      -- A breakpoint was hit; inform the user and tell them
      -- which breakpoint was hit.
      ForeignRef (ResumeContext ())
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 hmi :: HomeModInfo
hmi = String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
forall a b. (a -> b) -> a -> b
$
                  HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HasDebugCallStack => UnitEnv -> HomePackageTable
UnitEnv -> HomePackageTable
ue_hpt UnitEnv
unit_env)
                    (BreakIndex -> Unique
mkUniqueGrimily BreakIndex
mod_uniq)
          modl :: Module
modl = ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hmi)
          bp :: Maybe BreakInfo
bp | Bool
is_exception = Maybe BreakInfo
forall a. Maybe a
Nothing
             | Bool
otherwise = BreakInfo -> Maybe BreakInfo
forall a. a -> Maybe a
Just (Module -> BreakIndex -> BreakInfo
BreakInfo Module
modl BreakIndex
ix)
          sdocBpLoc :: Maybe BreakInfo -> SDoc
sdocBpLoc = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc)
-> (Maybe BreakInfo -> SDoc) -> Maybe BreakInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc)
-> (Maybe BreakInfo -> SrcSpan) -> Maybe BreakInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe BreakInfo -> SrcSpan
getSeqBpSpan
      String -> IO ()
putStrLn (String
"*** Ignoring breakpoint " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Maybe BreakInfo -> SDoc
sdocBpLoc Maybe BreakInfo
bp))
      -- resume the seq (:force) processing in the iserv process
      ForeignRef (ResumeContext ())
-> (RemoteRef (ResumeContext ()) -> IO (EvalResult ()))
-> IO (EvalResult ())
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext ())
resume_ctxt_fhv ((RemoteRef (ResumeContext ()) -> IO (EvalResult ()))
 -> IO (EvalResult ()))
-> (RemoteRef (ResumeContext ()) -> IO (EvalResult ()))
-> IO (EvalResult ())
forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext ())
hval -> do
        EvalStatus_ () ()
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)
        Interp -> UnitEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp UnitEnv
unit_env EvalStatus_ () ()
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 BreakInfo -> SrcSpan
    -- Just case: Stopped at a breakpoint, extract SrcSpan information
    -- from the breakpoint.
    getSeqBpSpan :: Maybe BreakInfo -> SrcSpan
getSeqBpSpan (Just BreakInfo{BreakIndex
Module
breakInfo_module :: Module
breakInfo_number :: BreakIndex
breakInfo_number :: BreakInfo -> BreakIndex
breakInfo_module :: BreakInfo -> Module
..}) =
      (ModBreaks -> Array BreakIndex SrcSpan
modBreaks_locs (Module -> ModBreaks
breaks Module
breakInfo_module)) Array BreakIndex SrcSpan -> BreakIndex -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
! BreakIndex
breakInfo_number
    -- Nothing case - should not occur!
    -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
    getSeqBpSpan Maybe BreakInfo
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. HasCallStack => 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 = 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 -> 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.
      UniqFM FastString (Ptr ())
cache <- MVar (UniqFM FastString (Ptr ()))
-> IO (UniqFM FastString (Ptr ()))
forall a. MVar a -> IO a
readMVar (ExtInterpInstance () -> MVar (UniqFM FastString (Ptr ()))
forall c. ExtInterpInstance c -> MVar (UniqFM FastString (Ptr ()))
instLookupSymbolCache ExtInterpInstance ()
inst)
      case UniqFM FastString (Ptr ()) -> FastString -> Maybe (Ptr ())
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString (Ptr ())
cache FastString
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
          Maybe (RemotePtr ())
m <- 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))
          case Maybe (RemotePtr ())
m of
            Maybe (RemotePtr ())
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 RemotePtr ()
r -> do
              let p :: Ptr ()
p        = RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
r
                  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_ (ExtInterpInstance () -> MVar (UniqFM FastString (Ptr ()))
forall c. ExtInterpInstance c -> MVar (UniqFM FastString (Ptr ()))
instLookupSymbolCache ExtInterpInstance ()
inst) (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 ())
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)

    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)

purgeLookupSymbolCache :: Interp -> IO ()
purgeLookupSymbolCache :: Interp -> IO ()
purgeLookupSymbolCache 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}. Maybe (ExtInterpInstance d) -> IO ()) -> IO ()
forall (m :: * -> *) a.
ExceptionMonad m =>
ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a
withExtInterpMaybe ExtInterp
ext ((forall {d}. Maybe (ExtInterpInstance d) -> IO ()) -> IO ())
-> (forall {d}. Maybe (ExtInterpInstance d) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (ExtInterpInstance d)
Nothing   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- interpreter stopped, nothing to do
    Just ExtInterpInstance d
inst -> MVar (UniqFM FastString (Ptr ()))
-> (UniqFM FastString (Ptr ()) -> IO (UniqFM FastString (Ptr ())))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (ExtInterpInstance d -> MVar (UniqFM FastString (Ptr ()))
forall c. ExtInterpInstance c -> MVar (UniqFM FastString (Ptr ()))
instLookupSymbolCache ExtInterpInstance d
inst) (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 key 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.
--
-- Returns:
--
-- Nothing      => success
-- Just err_msg => failure
loadDLL :: Interp -> String -> IO (Maybe String)
loadDLL :: Interp -> String -> IO (Maybe String)
loadDLL 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)
LoadDLL String
str)

loadArchive :: Interp -> String -> IO ()
loadArchive :: Interp -> String -> IO ()
loadArchive Interp
interp String
path = do
  String
path' <- String -> IO String
canonicalizePath String
path -- Note [loadObj and relative paths]
  Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message ()
LoadArchive String
path')

loadObj :: Interp -> String -> IO ()
loadObj :: Interp -> String -> IO ()
loadObj Interp
interp String
path = do
  String
path' <- String -> IO String
canonicalizePath String
path -- Note [loadObj and relative paths]
  Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message ()
LoadObj String
path')

unloadObj :: Interp -> String -> IO ()
unloadObj :: Interp -> String -> IO ()
unloadObj Interp
interp String
path = do
  String
path' <- String -> IO String
canonicalizePath String
path -- Note [loadObj and relative paths]
  Interp -> Message () -> IO ()
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message ()
UnloadObj String
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 { (Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
                                        ; ProcessHandle -> IO ProcessHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
ph })
                             (IServConfig -> Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook IServConfig
conf)
  (ProcessHandle
ph, Handle
rh, Handle
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)
  IORef (Maybe ByteString)
lo_ref <- Maybe ByteString -> IO (IORef (Maybe ByteString))
forall a. a -> IO (IORef a)
newIORef Maybe ByteString
forall a. Maybe a
Nothing
  let pipe :: Pipe
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
process = InterpProcess
                  { interpHandle :: ProcessHandle
interpHandle = ProcessHandle
ph
                  , interpPipe :: Pipe
interpPipe   = Pipe
pipe
                  }

  MVar [HValueRef]
pending_frees <- [HValueRef] -> IO (MVar [HValueRef])
forall a. a -> IO (MVar a)
newMVar []
  MVar (UniqFM FastString (Ptr ()))
lookup_cache  <- UniqFM FastString (Ptr ())
-> IO (MVar (UniqFM FastString (Ptr ())))
forall a. a -> IO (MVar a)
newMVar UniqFM FastString (Ptr ())
forall key elt. UniqFM key elt
emptyUFM
  let inst :: ExtInterpInstance ()
inst = ExtInterpInstance
        { instProcess :: InterpProcess
instProcess           = InterpProcess
process
        , instPendingFrees :: MVar [HValueRef]
instPendingFrees      = MVar [HValueRef]
pending_frees
        , instLookupSymbolCache :: MVar (UniqFM FastString (Ptr ()))
instLookupSymbolCache = MVar (UniqFM FastString (Ptr ()))
lookup_cache
        , instExtra :: ()
instExtra             = ()
        }
  ExtInterpInstance () -> IO (ExtInterpInstance ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtInterpInstance ()
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 (m :: * -> *) a.
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
            Maybe ExitCode
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode (InterpProcess -> ProcessHandle
interpHandle (ExtInterpInstance d -> InterpProcess
forall c. ExtInterpInstance c -> InterpProcess
instProcess ExtInterpInstance d
i))
            if Maybe ExitCode -> Bool
forall a. Maybe a -> Bool
isJust Maybe ExitCode
ex
               then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
               else ExtInterpInstance d -> Message () -> IO ()
forall a d. Binary a => ExtInterpInstance d -> Message a -> IO a
sendMessage ExtInterpInstance d
i Message ()
Shutdown
            InterpStatus (ExtInterpInstance d)
-> IO (InterpStatus (ExtInterpInstance d))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpStatus (ExtInterpInstance d)
forall inst. InterpStatus inst
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. 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. 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] <- (Unlinked -> Maybe CompiledByteCode)
-> [Unlinked] -> [CompiledByteCode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Unlinked -> Maybe CompiledByteCode
onlyBCOs ([Unlinked] -> [CompiledByteCode])
-> [Unlinked] -> [CompiledByteCode]
forall a b. (a -> b) -> a -> b
$ Linkable -> [Unlinked]
linkableUnlinked 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
  where
    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
    onlyBCOs :: Unlinked -> Maybe CompiledByteCode
    onlyBCOs :: Unlinked -> Maybe CompiledByteCode
onlyBCOs (BCOs CompiledByteCode
cbc [SptEntry]
_) = CompiledByteCode -> Maybe CompiledByteCode
forall a. a -> Maybe a
Just CompiledByteCode
cbc
    onlyBCOs Unlinked
_            = Maybe CompiledByteCode
forall a. Maybe a
Nothing

-- | 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