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

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

  -- * Lower-level API using messages
  , interpCmd, Message(..), withIServ, withIServ_
  , hscInterp, stopInterp
  , iservCall, readIServ, writeIServ
  , purgeLookupSymbolCache
  , freeHValueRefs
  , mkFinalizedHValue
  , wormhole, wormholeRef
  , mkEvalOpts
  , fromEvalResult
  ) where

import GHC.Prelude

import GHC.Driver.Ppr (showSDoc)
import GHC.Driver.Env
import GHC.Driver.Session

import GHC.Runtime.Interpreter.Types
import GHCi.Message
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
import GHC.Runtime.Eval.Types(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)
import GHC.Utils.Fingerprint
import GHC.Utils.Misc

import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo

#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, onException)
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.Exit
import GHC.IO.Handle.Types (Handle)
#if defined(mingw32_HOST_OS)
import Foreign.C
import GHC.IO.Handle.FD (fdToHandle)
#else
import System.Posix as Posix
#endif
import System.Directory
import System.Process
import GHC.Conc (getNumProcessors, 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     -> forall a. Message a -> IO a
run Message a
msg -- Just run it directly
#endif
  ExternalInterp IServConfig
c IServ
i -> forall (m :: * -> *) a.
(MonadIO m, ExceptionMonad m) =>
IServConfig -> IServ -> (IServInstance -> m a) -> m a
withIServ_ IServConfig
c IServ
i forall a b. (a -> b) -> a -> b
$ \IServInstance
iserv ->
    forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ -- Note [uninterruptibleMask_]
      forall a. Binary a => IServInstance -> Message a -> IO a
iservCall IServInstance
iserv Message a
msg


-- | Retrieve the target code interpreter
--
-- Fails if no target code interpreter is available
hscInterp :: HscEnv -> Interp
hscInterp :: HscEnv -> Interp
hscInterp HscEnv
hsc_env = case HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
   Maybe Interp
Nothing -> forall a e. Exception e => e -> a
throw (String -> GhcException
InstallationError String
"Couldn't find a target code interpreter. Try with -fexternal-interpreter")
   Just Interp
i  -> Interp
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)
  => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ :: forall (m :: * -> *) a.
ExceptionMonad m =>
IServConfig
-> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ IServConfig
conf (IServ MVar IServState
mIServState) IServInstance -> m (IServInstance, a)
action =
  forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    IServState
state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar IServState
mIServState

    IServInstance
iserv <- case IServState
state of
      -- start the external iserv process if we haven't done so yet
      IServState
IServPending ->
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IServConfig -> IO IServInstance
spawnIServ IServConfig
conf)
           forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`MC.onException` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar IServState
mIServState IServState
state)

      IServRunning IServInstance
inst -> forall (m :: * -> *) a. Monad m => a -> m a
return IServInstance
inst


    let iserv' :: IServInstance
iserv'  = IServInstance
iserv{ iservPendingFrees :: [HValueRef]
iservPendingFrees = [] }

    (IServInstance
iserv'',a
a) <- (do
      -- free any ForeignHValues that have been garbage collected.
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (IServInstance -> [HValueRef]
iservPendingFrees IServInstance
iserv))) forall a b. (a -> b) -> a -> b
$
        forall a. Binary a => IServInstance -> Message a -> IO a
iservCall IServInstance
iserv ([HValueRef] -> Message ()
FreeHValueRefs (IServInstance -> [HValueRef]
iservPendingFrees IServInstance
iserv))
      -- run the inner action
      forall a. m a -> m a
restore forall a b. (a -> b) -> a -> b
$ IServInstance -> m (IServInstance, a)
action IServInstance
iserv')
          forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`MC.onException` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar IServState
mIServState (IServInstance -> IServState
IServRunning IServInstance
iserv'))
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar IServState
mIServState (IServInstance -> IServState
IServRunning IServInstance
iserv'')
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a

withIServ_
  :: (MonadIO m, ExceptionMonad m)
  => IServConfig -> IServ -> (IServInstance -> m a) -> m a
withIServ_ :: forall (m :: * -> *) a.
(MonadIO m, ExceptionMonad m) =>
IServConfig -> IServ -> (IServInstance -> m a) -> m a
withIServ_ IServConfig
conf IServ
iserv IServInstance -> m a
action = forall (m :: * -> *) a.
ExceptionMonad m =>
IServConfig
-> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ IServConfig
conf IServ
iserv forall a b. (a -> b) -> a -> b
$ \IServInstance
inst ->
   (IServInstance
inst,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IServInstance -> m a
action IServInstance
inst

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

-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
-- each of the results.
evalStmt
  :: Interp
  -> DynFlags -- used by mkEvalOpts
  -> Bool     -- "step" for mkEvalOpts
  -> EvalExpr ForeignHValue
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt :: Interp
-> DynFlags
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt Interp
interp DynFlags
dflags Bool
step EvalExpr ForeignHValue
foreign_expr = do
  EvalStatus_ [HValueRef] [HValueRef]
status <- forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
foreign_expr forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
expr ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (EvalOpts
-> EvalExpr HValueRef
-> Message (EvalStatus_ [HValueRef] [HValueRef])
EvalStmt (DynFlags -> Bool -> EvalOpts
mkEvalOpts DynFlags
dflags Bool
step) 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 =
    forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv forall a b. (a -> b) -> a -> b
$ \HValueRef
hvref -> EvalExpr HValueRef -> IO a
cont (forall a. a -> EvalExpr a
EvalThis HValueRef
hvref)
  withExpr (EvalApp EvalExpr ForeignHValue
fl EvalExpr ForeignHValue
fr) EvalExpr HValueRef -> IO a
cont =
    forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
fl forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
fl' ->
    forall a.
EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr EvalExpr ForeignHValue
fr forall a b. (a -> b) -> a -> b
$ \EvalExpr HValueRef
fr' ->
    EvalExpr HValueRef -> IO a
cont (forall a. EvalExpr a -> EvalExpr a -> EvalExpr a
EvalApp EvalExpr HValueRef
fl' EvalExpr HValueRef
fr')

resumeStmt
  :: Interp
  -> DynFlags -- used by mkEvalOpts
  -> Bool     -- "step" for mkEvalOpts
  -> ForeignRef (ResumeContext [HValueRef])
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt :: Interp
-> DynFlags
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt Interp
interp DynFlags
dflags Bool
step ForeignRef (ResumeContext [HValueRef])
resume_ctxt = do
  EvalStatus_ [HValueRef] [HValueRef]
status <- forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext [HValueRef])
resume_ctxt forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext [HValueRef])
rhv ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> Message (EvalStatus_ [HValueRef] [HValueRef])
ResumeStmt (DynFlags -> Bool -> EvalOpts
mkEvalOpts DynFlags
dflags Bool
step) 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 =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext [HValueRef])
resume_ctxt forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext [HValueRef])
rhv ->
    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 Int
c Int
d RemoteRef (ResumeContext [HValueRef])
e RemotePtr CostCentreStack
f -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b.
Bool
-> HValueRef
-> Int
-> Int
-> RemoteRef (ResumeContext b)
-> RemotePtr CostCentreStack
-> EvalStatus_ a b
EvalBreak Bool
a HValueRef
b Int
c Int
d RemoteRef (ResumeContext [HValueRef])
e RemotePtr CostCentreStack
f)
    EvalComplete Word64
alloc EvalResult [HValueRef]
res ->
      forall a b. Word64 -> EvalResult a -> EvalStatus_ a b
EvalComplete Word64
alloc 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SerializableException -> EvalResult a
EvalException SerializableException
e)
  addFinalizer (EvalSuccess [HValueRef]
rs)  =
    forall a. a -> EvalResult a
EvalSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalResult ())
EvalIO HValueRef
fhv) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalResult String)
EvalString HValueRef
fhv) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
fhv forall a b. (a -> b) -> a -> b
$ \HValueRef
fhv ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> String -> Message (EvalResult String)
EvalStringToString HValueRef
fhv String
str) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = 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 =
  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 -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]
createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]
createBCOs Interp
interp DynFlags
dflags [ResolvedBCO]
rbcos = do
  Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount DynFlags
dflags of
              Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
              Just Int
n  -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
  -- (-j<n>) parallelise the serialization.
  if (Int
n_jobs forall a. Eq a => a -> a -> Bool
== Int
1)
    then
      forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [HValueRef]
CreateBCOs [Put -> ByteString
runPut (forall t. Binary t => t -> Put
put [ResolvedBCO]
rbcos)])

    else do
      Int
old_caps <- IO Int
getNumCapabilities
      if Int
old_caps forall a. Eq a => a -> a -> Bool
== Int
n_jobs
         then forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate [ByteString]
puts
         else forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Int -> IO ()
setNumCapabilities Int
n_jobs)
                       (Int -> IO ()
setNumCapabilities Int
old_caps)
                       (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate [ByteString]
puts)
      forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp ([ByteString] -> Message [HValueRef]
CreateBCOs [ByteString]
puts)
 where
  puts :: [ByteString]
puts = forall {t} {a}. (t -> a) -> [t] -> [a]
parMap forall {t}. Binary t => t -> ByteString
doChunk (forall a. Int -> [a] -> [[a]]
chunkList Int
100 [ResolvedBCO]
rbcos)

  -- make sure we force the whole lazy ByteString
  doChunk :: t -> ByteString
doChunk t
c = forall a b. a -> b -> b
pseq (ByteString -> Int64
LB.length ByteString
bs) ByteString
bs
    where bs :: ByteString
bs = Put -> ByteString
runPut (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 forall a b. a -> b -> b
`par` ([a]
fxs forall a b. a -> b -> b
`pseq` (a
fx 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 =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref forall a b. (a -> b) -> a -> b
$ \HValueRef
val ->
    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 =
  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 -> Int -> IO (ForeignRef BreakArray)
newBreakArray Interp
interp Int
size = do
  RemoteRef BreakArray
breakArray <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Int -> Message (RemoteRef BreakArray)
NewBreakArray Int
size)
  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 -> Int -> Int -> IO ()
storeBreakpoint Interp
interp ForeignRef BreakArray
ref Int
ix Int
cnt = do                               -- #19157
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
ref forall a b. (a -> b) -> a -> b
$ \RemoteRef BreakArray
breakarray ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef BreakArray -> Int -> Int -> Message ()
SetupBreakpoint RemoteRef BreakArray
breakarray Int
ix Int
cnt)

breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus Interp
interp ForeignRef BreakArray
ref Int
ix =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
ref forall a b. (a -> b) -> a -> b
$ \RemoteRef BreakArray
breakarray ->
    forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef BreakArray -> Int -> Message Bool
BreakpointStatus RemoteRef BreakArray
breakarray Int
ix)

getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar Interp
interp ForeignHValue
ref Int
ix =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref forall a b. (a -> b) -> a -> b
$ \HValueRef
apStack -> do
    Maybe HValueRef
mb <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Int -> Message (Maybe HValueRef)
GetBreakpointVar HValueRef
apStack Int
ix)
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref forall a b. (a -> b) -> a -> b
$ \HValueRef
hval -> do
    GenClosure HValueRef
mb <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (GenClosure HValueRef)
GetClosure HValueRef
hval)
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 -> HscEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())
seqHValue Interp
interp HscEnv
hsc_env ForeignHValue
ref =
  forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
ref forall a b. (a -> b) -> a -> b
$ \HValueRef
hval -> do
    EvalStatus_ () ()
status <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (HValueRef -> Message (EvalStatus_ () ())
Seq HValueRef
hval)
    Interp -> HscEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp HscEnv
hsc_env EvalStatus_ () ()
status

-- | Process the result of a Seq or ResumeSeq message.             #2950
handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())
handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp HscEnv
hsc_env EvalStatus_ () ()
eval_status =
  case EvalStatus_ () ()
eval_status of
    (EvalBreak Bool
is_exception HValueRef
_ Int
ix Int
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Interp -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue Interp
interp RemoteRef (ResumeContext ())
resume_ctxt
      let hmi :: HomeModInfo
hmi = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"handleRunStatus" forall a b. (a -> b) -> a -> b
$
                  HomePackageTable -> Unique -> Maybe HomeModInfo
lookupHptDirectly (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                    (Int -> Unique
mkUniqueGrimily Int
mod_uniq)
          modl :: Module
modl = forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
          bp :: Maybe BreakInfo
bp | Bool
is_exception = forall a. Maybe a
Nothing
             | Bool
otherwise = forall a. a -> Maybe a
Just (Module -> Int -> BreakInfo
BreakInfo Module
modl Int
ix)
          sdocBpLoc :: Maybe BreakInfo -> SDoc
sdocBpLoc = SDoc -> SDoc
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe BreakInfo -> SrcSpan
getSeqBpSpan
      String -> IO ()
putStrLn (String
"*** Ignoring breakpoint " forall a. [a] -> [a] -> [a]
++
            (DynFlags -> SDoc -> String
showSDoc (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) forall a b. (a -> b) -> a -> b
$ Maybe BreakInfo -> SDoc
sdocBpLoc Maybe BreakInfo
bp))
      -- resume the seq (:force) processing in the iserv process
      forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef (ResumeContext ())
resume_ctxt_fhv forall a b. (a -> b) -> a -> b
$ \RemoteRef (ResumeContext ())
hval -> do
        EvalStatus_ () ()
status <- forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemoteRef (ResumeContext ()) -> Message (EvalStatus_ () ())
ResumeSeq RemoteRef (ResumeContext ())
hval)
        Interp -> HscEnv -> EvalStatus_ () () -> IO (EvalResult ())
handleSeqHValueStatus Interp
interp HscEnv
hsc_env EvalStatus_ () ()
status
    (EvalComplete Word64
_ EvalResult ()
r) -> 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{Int
Module
breakInfo_number :: BreakInfo -> Int
breakInfo_module :: BreakInfo -> Module
breakInfo_number :: Int
breakInfo_module :: Module
..}) =
      (ModBreaks -> Array Int SrcSpan
modBreaks_locs (Module -> ModBreaks
breaks Module
breakInfo_module)) forall i e. Ix i => Array i e -> i -> e
! Int
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 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"getSeqBpSpan" forall a b. (a -> b) -> a -> b
$
      HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)


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

initObjLinker :: Interp -> IO ()
initObjLinker :: Interp -> IO ()
initObjLinker Interp
interp = 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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. RemotePtr a -> Ptr a
fromRemotePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Message a -> IO a
run (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
#endif

  ExternalInterp IServConfig
c IServ
i -> forall (m :: * -> *) a.
ExceptionMonad m =>
IServConfig
-> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
withIServ IServConfig
c IServ
i forall a b. (a -> b) -> a -> b
$ \IServInstance
iserv -> 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.
    let cache :: UniqFM FastString (Ptr ())
cache = IServInstance -> UniqFM FastString (Ptr ())
iservLookupSymbolCache IServInstance
iserv
    case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString (Ptr ())
cache FastString
str of
      Just Ptr ()
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (IServInstance
iserv, forall a. a -> Maybe a
Just Ptr ()
p)
      Maybe (Ptr ())
Nothing -> do
        Maybe (RemotePtr ())
m <- forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$
                 forall a. Binary a => IServInstance -> Message a -> IO a
iservCall IServInstance
iserv (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
        case Maybe (RemotePtr ())
m of
          Maybe (RemotePtr ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (IServInstance
iserv, forall a. Maybe a
Nothing)
          Just RemotePtr ()
r -> do
            let p :: Ptr ()
p      = forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
r
                cache' :: UniqFM FastString (Ptr ())
cache' = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM FastString (Ptr ())
cache FastString
str Ptr ()
p
                iserv' :: IServInstance
iserv' = IServInstance
iserv {iservLookupSymbolCache :: UniqFM FastString (Ptr ())
iservLookupSymbolCache = UniqFM FastString (Ptr ())
cache'}
            forall (m :: * -> *) a. Monad m => a -> m a
return (IServInstance
iserv', forall a. a -> Maybe a
Just Ptr ()
p)

lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
lookupClosure Interp
interp String
str =
  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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
  ExternalInterp IServConfig
_ (IServ MVar IServState
mstate) ->
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar IServState
mstate forall a b. (a -> b) -> a -> b
$ \IServState
state -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case IServState
state of
      IServState
IServPending       -> IServState
state
      IServRunning IServInstance
iserv -> IServInstance -> IServState
IServRunning
        (IServInstance
iserv { iservLookupSymbolCache :: UniqFM FastString (Ptr ())
iservLookupSymbolCache = 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 = 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]
  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]
  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]
  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 =
  forall a. RemotePtr a -> Ptr a
fromRemotePtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
  forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (RemotePtr () -> Message Bool
RemoveLibrarySearchPath (forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))

resolveObjs :: Interp -> IO SuccessFlag
resolveObjs :: Interp -> IO SuccessFlag
resolveObjs Interp
interp = Bool -> SuccessFlag
successIf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (String -> Message (Maybe String)
FindSystemLibrary String
str)


-- -----------------------------------------------------------------------------
-- Raw calls and messages

-- | Send a 'Message' and receive the response from the iserv process
iservCall :: Binary a => IServInstance -> Message a -> IO a
iservCall :: forall a. Binary a => IServInstance -> Message a -> IO a
iservCall IServInstance
iserv Message a
msg =
  forall a. Binary a => Pipe -> Message a -> IO a
remoteCall (IServInstance -> Pipe
iservPipe IServInstance
iserv) Message a
msg
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> forall a. IServInstance -> SomeException -> IO a
handleIServFailure IServInstance
iserv SomeException
e

-- | Read a value from the iserv process
readIServ :: IServInstance -> Get a -> IO a
readIServ :: forall a. IServInstance -> Get a -> IO a
readIServ IServInstance
iserv Get a
get =
  forall a. Pipe -> Get a -> IO a
readPipe (IServInstance -> Pipe
iservPipe IServInstance
iserv) Get a
get
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> forall a. IServInstance -> SomeException -> IO a
handleIServFailure IServInstance
iserv SomeException
e

-- | Send a value to the iserv process
writeIServ :: IServInstance -> Put -> IO ()
writeIServ :: IServInstance -> Put -> IO ()
writeIServ IServInstance
iserv Put
put =
  Pipe -> Put -> IO ()
writePipe (IServInstance -> Pipe
iservPipe IServInstance
iserv) Put
put
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> forall a. IServInstance -> SomeException -> IO a
handleIServFailure IServInstance
iserv SomeException
e

handleIServFailure :: IServInstance -> SomeException -> IO a
handleIServFailure :: forall a. IServInstance -> SomeException -> IO a
handleIServFailure IServInstance
iserv SomeException
e = do
  let proc :: ProcessHandle
proc = IServInstance -> ProcessHandle
iservProcess IServInstance
iserv
  Maybe ExitCode
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
proc
  case Maybe ExitCode
ex of
    Just (ExitFailure Int
n) ->
      forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError (String
"ghc-iserv terminated (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
")"))
    Maybe ExitCode
_ -> do
      ProcessHandle -> IO ()
terminateProcess ProcessHandle
proc
      ExitCode
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
proc
      forall a e. Exception e => e -> a
throw SomeException
e

-- | Spawn an external interpreter
spawnIServ :: IServConfig -> IO IServInstance
spawnIServ :: IServConfig -> IO IServInstance
spawnIServ IServConfig
conf = do
  IServConfig -> IO ()
iservConfTrace IServConfig
conf
  let createProc :: CreateProcess -> IO ProcessHandle
createProc = 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
                                        ; 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] -> IO (ProcessHandle, Handle, Handle)
runWithPipes CreateProcess -> IO ProcessHandle
createProc (IServConfig -> String
iservConfProgram IServConfig
conf)
                                          (IServConfig -> [String]
iservConfOpts    IServConfig
conf)
  IORef (Maybe ByteString)
lo_ref <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IServInstance
    { iservPipe :: Pipe
iservPipe              = Pipe { pipeRead :: Handle
pipeRead = Handle
rh, pipeWrite :: Handle
pipeWrite = Handle
wh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref }
    , iservProcess :: ProcessHandle
iservProcess           = ProcessHandle
ph
    , iservLookupSymbolCache :: UniqFM FastString (Ptr ())
iservLookupSymbolCache = forall key elt. UniqFM key elt
emptyUFM
    , iservPendingFrees :: [HValueRef]
iservPendingFrees      = []
    }

-- | 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
    ExternalInterp IServConfig
_ (IServ MVar IServState
mstate) ->
      forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MC.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_restore -> forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar IServState
mstate forall a b. (a -> b) -> a -> b
$ \IServState
state -> do
        case IServState
state of
          IServState
IServPending    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IServState
state -- already stopped
          IServRunning IServInstance
i  -> do
            Maybe ExitCode
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode (IServInstance -> ProcessHandle
iservProcess IServInstance
i)
            if forall a. Maybe a -> Bool
isJust Maybe ExitCode
ex
               then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
               else forall a. Binary a => IServInstance -> Message a -> IO a
iservCall IServInstance
i Message ()
Shutdown
            forall (f :: * -> *) a. Applicative f => a -> f a
pure IServState
IServPending

runWithPipes :: (CreateProcess -> IO ProcessHandle)
             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
#if defined(mingw32_HOST_OS)
foreign import ccall "io.h _close"
   c__close :: CInt -> IO CInt

foreign import ccall unsafe "io.h _get_osfhandle"
   _get_osfhandle :: CInt -> IO CInt

runWithPipes createProc prog opts = do
    (rfd1, wfd1) <- createPipeFd -- we read on rfd1
    (rfd2, wfd2) <- createPipeFd -- we write on wfd2
    wh_client    <- _get_osfhandle wfd1
    rh_client    <- _get_osfhandle rfd2
    let args = show wh_client : show rh_client : opts
    ph <- createProc (proc prog args)
    rh <- mkHandle rfd1
    wh <- mkHandle wfd2
    return (ph, rh, wh)
      where mkHandle :: CInt -> IO Handle
            mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)

#else
runWithPipes :: (CreateProcess -> IO ProcessHandle)
-> String -> [String] -> IO (ProcessHandle, Handle, Handle)
runWithPipes CreateProcess -> IO ProcessHandle
createProc String
prog [String]
opts = do
    (Fd
rfd1, Fd
wfd1) <- IO (Fd, Fd)
Posix.createPipe -- we read on rfd1
    (Fd
rfd2, Fd
wfd2) <- IO (Fd, Fd)
Posix.createPipe -- we write on wfd2
    Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
rfd1 FdOption
CloseOnExec Bool
True
    Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
wfd2 FdOption
CloseOnExec Bool
True
    let args :: [String]
args = forall a. Show a => a -> String
show Fd
wfd1 forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Fd
rfd2 forall a. a -> [a] -> [a]
: [String]
opts
    ProcessHandle
ph <- CreateProcess -> IO ProcessHandle
createProc (String -> [String] -> CreateProcess
proc String
prog [String]
args)
    Fd -> IO ()
closeFd Fd
wfd1
    Fd -> IO ()
closeFd Fd
rfd2
    Handle
rh <- Fd -> IO Handle
fdToHandle Fd
rfd1
    Handle
wh <- Fd -> IO Handle
fdToHandle Fd
wfd2
    forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle
ph, Handle
rh, Handle
wh)
#endif

-- -----------------------------------------------------------------------------
{- 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 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
   let hvref :: HValueRef
hvref = forall a. RemoteRef a -> HValueRef
toHValueRef RemoteRef a
rref

   IO ()
free <- case Interp -> InterpInstance
interpInstance Interp
interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
      InterpInstance
InternalInterp             -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. RemoteRef a -> IO ()
freeRemoteRef HValueRef
hvref)
#endif
      ExternalInterp IServConfig
_ (IServ MVar IServState
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar IServState
i forall a b. (a -> b) -> a -> b
$ \IServState
state ->
       case IServState
state of
         IServPending {}   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IServState
state -- already shut down
         IServRunning IServInstance
inst -> do
            let !inst' :: IServInstance
inst' = IServInstance
inst {iservPendingFrees :: [HValueRef]
iservPendingFrees = HValueRef
hvrefforall a. a -> [a] -> [a]
:IServInstance -> [HValueRef]
iservPendingFrees IServInstance
inst}
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (IServInstance -> IServState
IServRunning IServInstance
inst')

   forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef RemoteRef a
rref IO ()
free


freeHValueRefs :: Interp -> [HValueRef] -> IO ()
freeHValueRefs :: Interp -> [HValueRef] -> IO ()
freeHValueRefs Interp
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeHValueRefs Interp
interp [HValueRef]
refs = 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 = forall a. Interp -> RemoteRef a -> IO a
wormholeRef Interp
interp (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 -> forall a. RemoteRef a -> IO a
localRef RemoteRef a
_r
#endif
  ExternalInterp {}
    -> forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError String
"this operation requires -fno-external-interpreter")

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

mkEvalOpts :: DynFlags -> Bool -> EvalOpts
mkEvalOpts :: DynFlags -> Bool -> EvalOpts
mkEvalOpts DynFlags
dflags Bool
step =
  EvalOpts
    { useSandboxThread :: Bool
useSandboxThread = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GhciSandbox DynFlags
dflags
    , singleStep :: Bool
singleStep = Bool
step
    , breakOnException :: Bool
breakOnException = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BreakOnException DynFlags
dflags
    , breakOnError :: Bool
breakOnError = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BreakOnError DynFlags
dflags }

fromEvalResult :: EvalResult a -> IO a
fromEvalResult :: forall a. EvalResult a -> IO a
fromEvalResult (EvalException SerializableException
e) = forall e a. Exception e => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
fromEvalResult (EvalSuccess a
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
hm_linkable HomeModInfo
hmi,
    [CompiledByteCode
cbc] <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Unlinked -> Maybe CompiledByteCode
onlyBCOs forall a b. (a -> b) -> a -> b
$ Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
  = 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]
_) = forall a. a -> Maybe a
Just CompiledByteCode
cbc
    onlyBCOs Unlinked
_            = 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 IServConfig
c IServ
_ -> IServConfig -> Bool
iservConfProfiled IServConfig
c

-- | 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 IServConfig
c IServ
_ -> IServConfig -> Bool
iservConfDynamic IServConfig
c