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

--
-- | Interacting with the interpreter, whether it is running on an
-- external process or in the current process.
--
module GHCi
  ( -- * High-level interface to the interpreter
    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
  , resumeStmt
  , abandonStmt
  , evalIO
  , evalString
  , evalStringToIOString
  , mallocData
  , createBCOs
  , addSptEntry
  , mkCostCentres
  , costCentreStackInfo
  , newBreakArray
  , enableBreakpoint
  , breakpointStatus
  , getBreakpointVar
  , getClosure
  , seqHValue

  -- * The object-code linker
  , initObjLinker
  , lookupSymbol
  , lookupClosure
  , loadDLL
  , loadArchive
  , loadObj
  , unloadObj
  , addLibrarySearchPath
  , removeLibrarySearchPath
  , resolveObjs
  , findSystemLibrary

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

import GhcPrelude

import GHCi.Message
#if defined(GHCI)
import GHCi.Run
#endif
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray (BreakArray)
import Fingerprint
import HscTypes
import UniqFM
import Panic
import DynFlags
import ErrUtils
import Outputable
import Exception
import BasicTypes
import FastString
import Util
import Hooks

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Binary
import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.IORef
import Foreign hiding (void)
import GHC.Exts.Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
import Data.Maybe
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 RemoteGHCi 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 (GHCi) 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://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter
  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
-}

#if !defined(GHCI)
needExtInt :: IO a
needExtInt :: IO a
needExtInt = GhcException -> IO a
forall e a. Exception e => e -> IO a
throwIO
  (String -> GhcException
InstallationError "this operation requires -fexternal-interpreter")
#endif

-- | 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.
iservCmd :: Binary a => HscEnv -> Message a -> IO a
iservCmd :: HscEnv -> Message a -> IO a
iservCmd hsc_env :: HscEnv
hsc_env@HscEnv{..} msg :: Message a
msg
 | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
hsc_dflags =
     HscEnv -> (IServ -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, ExceptionMonad m) =>
HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv
hsc_env ((IServ -> IO a) -> IO a) -> (IServ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \iserv :: IServ
iserv ->
       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
$ do -- Note [uninterruptibleMask_]
         IServ -> Message a -> IO a
forall a. Binary a => IServ -> Message a -> IO a
iservCall IServ
iserv Message a
msg
 | Bool
otherwise = -- Just run it directly
#if defined(GHCI)
   run msg
#else
   IO a
forall a. IO a
needExtInt
#endif

-- Note [uninterruptibleMask_ and iservCmd]
--
-- 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 recoever.  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
  :: (MonadIO m, ExceptionMonad m)
  => HscEnv -> (IServ -> m a) -> m a
withIServ :: HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv{..} action :: IServ -> m a
action =
  ((m a -> m a) -> m a) -> m a
forall (m :: * -> *) a b.
ExceptionMonad m =>
((m a -> m a) -> m b) -> m b
gmask (((m a -> m a) -> m a) -> m a) -> ((m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \restore :: m a -> m a
restore -> do
    Maybe IServ
m <- IO (Maybe IServ) -> m (Maybe IServ)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe IServ) -> m (Maybe IServ))
-> IO (Maybe IServ) -> m (Maybe IServ)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe IServ) -> IO (Maybe IServ)
forall a. MVar a -> IO a
takeMVar MVar (Maybe IServ)
hsc_iserv
      -- start the iserv process if we haven't done so yet
    IServ
iserv <- m IServ -> (IServ -> m IServ) -> Maybe IServ -> m IServ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO IServ -> m IServ
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IServ -> m IServ) -> IO IServ -> m IServ
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO IServ
startIServ DynFlags
hsc_dflags) IServ -> m IServ
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IServ
m
               m IServ -> m () -> m IServ
forall (m :: * -> *) a b. ExceptionMonad m => m a -> m b -> m a
`gonException` (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe IServ) -> Maybe IServ -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe IServ)
hsc_iserv Maybe IServ
forall a. Maybe a
Nothing)
      -- free any ForeignHValues that have been garbage collected.
    let iserv' :: IServ
iserv' = IServ
iserv{ iservPendingFrees :: [HValueRef]
iservPendingFrees = [] }
    a
a <- (do
      IO () -> m ()
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 (t :: * -> *) a. Foldable t => t a -> Bool
null (IServ -> [HValueRef]
iservPendingFrees IServ
iserv))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IServ -> Message () -> IO ()
forall a. Binary a => IServ -> Message a -> IO a
iservCall IServ
iserv ([HValueRef] -> Message ()
FreeHValueRefs (IServ -> [HValueRef]
iservPendingFrees IServ
iserv))
        -- run the inner action
      m a -> m a
restore (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ IServ -> m a
action IServ
iserv)
          m a -> m () -> m a
forall (m :: * -> *) a b. ExceptionMonad m => m a -> m b -> m a
`gonException` (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe IServ) -> Maybe IServ -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe IServ)
hsc_iserv (IServ -> Maybe IServ
forall a. a -> Maybe a
Just IServ
iserv'))
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe IServ) -> Maybe IServ -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe IServ)
hsc_iserv (IServ -> Maybe IServ
forall a. a -> Maybe a
Just IServ
iserv')
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


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

-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
-- each of the results.
evalStmt
  :: HscEnv -> Bool -> EvalExpr ForeignHValue
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt :: HscEnv
-> Bool
-> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
evalStmt hsc_env :: HscEnv
hsc_env step :: Bool
step foreign_expr :: EvalExpr ForeignHValue
foreign_expr = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  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
$ \expr :: EvalExpr HValueRef
expr ->
    HscEnv
-> Message (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (EvalOpts
-> EvalExpr HValueRef
-> Message (EvalStatus_ [HValueRef] [HValueRef])
EvalStmt (DynFlags -> Bool -> EvalOpts
mkEvalOpts DynFlags
dflags Bool
step) EvalExpr HValueRef
expr)
  HscEnv
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus HscEnv
hsc_env EvalStatus_ [HValueRef] [HValueRef]
status
 where
  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr (EvalThis fhv :: ForeignHValue
fhv) cont :: 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
$ \hvref :: HValueRef
hvref -> EvalExpr HValueRef -> IO a
cont (HValueRef -> EvalExpr HValueRef
forall a. a -> EvalExpr a
EvalThis HValueRef
hvref)
  withExpr (EvalApp fl :: EvalExpr ForeignHValue
fl fr :: EvalExpr ForeignHValue
fr) cont :: 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
$ \fl' :: 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
$ \fr' :: 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
  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt :: HscEnv
-> Bool
-> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
resumeStmt hsc_env :: HscEnv
hsc_env step :: Bool
step resume_ctxt :: ForeignRef (ResumeContext [HValueRef])
resume_ctxt = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  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
$ \rhv :: RemoteRef (ResumeContext [HValueRef])
rhv ->
    HscEnv
-> Message (EvalStatus_ [HValueRef] [HValueRef])
-> IO (EvalStatus_ [HValueRef] [HValueRef])
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> Message (EvalStatus_ [HValueRef] [HValueRef])
ResumeStmt (DynFlags -> Bool -> EvalOpts
mkEvalOpts DynFlags
dflags Bool
step) RemoteRef (ResumeContext [HValueRef])
rhv)
  HscEnv
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus HscEnv
hsc_env EvalStatus_ [HValueRef] [HValueRef]
status

abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
abandonStmt hsc_env :: HscEnv
hsc_env resume_ctxt :: ForeignRef (ResumeContext [HValueRef])
resume_ctxt = do
  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
$ \rhv :: RemoteRef (ResumeContext [HValueRef])
rhv ->
    HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (RemoteRef (ResumeContext [HValueRef]) -> Message ()
AbandonStmt RemoteRef (ResumeContext [HValueRef])
rhv)

handleEvalStatus
  :: HscEnv -> EvalStatus [HValueRef]
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus :: HscEnv
-> EvalStatus_ [HValueRef] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
handleEvalStatus hsc_env :: HscEnv
hsc_env status :: EvalStatus_ [HValueRef] [HValueRef]
status =
  case EvalStatus_ [HValueRef] [HValueRef]
status of
    EvalBreak a :: Bool
a b :: HValueRef
b c :: Int
c d :: Int
d e :: RemoteRef (ResumeContext [HValueRef])
e f :: RemotePtr CostCentreStack
f -> EvalStatus_ [ForeignHValue] [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
-> HValueRef
-> Int
-> Int
-> RemoteRef (ResumeContext [HValueRef])
-> RemotePtr CostCentreStack
-> EvalStatus_ [ForeignHValue] [HValueRef]
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 alloc :: Word64
alloc res :: 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])
forall (t :: * -> *) a.
Traversable t =>
EvalResult (t (RemoteRef a)) -> IO (EvalResult (t (ForeignRef a)))
addFinalizer EvalResult [HValueRef]
res
 where
  addFinalizer :: EvalResult (t (RemoteRef a)) -> IO (EvalResult (t (ForeignRef a)))
addFinalizer (EvalException e :: SerializableException
e) = EvalResult (t (ForeignRef a)) -> IO (EvalResult (t (ForeignRef a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (SerializableException -> EvalResult (t (ForeignRef a))
forall a. SerializableException -> EvalResult a
EvalException SerializableException
e)
  addFinalizer (EvalSuccess rs :: t (RemoteRef a)
rs) = do
    t (ForeignRef a) -> EvalResult (t (ForeignRef a))
forall a. a -> EvalResult a
EvalSuccess (t (ForeignRef a) -> EvalResult (t (ForeignRef a)))
-> IO (t (ForeignRef a)) -> IO (EvalResult (t (ForeignRef a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RemoteRef a -> IO (ForeignRef a))
-> t (RemoteRef a) -> IO (t (ForeignRef a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> RemoteRef a -> IO (ForeignRef a)
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env) t (RemoteRef a)
rs

-- | Execute an action of type @IO ()@
evalIO :: HscEnv -> ForeignHValue -> IO ()
evalIO :: HscEnv -> ForeignHValue -> IO ()
evalIO hsc_env :: HscEnv
hsc_env fhv :: ForeignHValue
fhv = do
  IO () -> IO ()
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
$ \fhv :: HValueRef
fhv ->
    HscEnv -> Message (EvalResult ()) -> IO (EvalResult ())
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (HValueRef -> Message (EvalResult ())
EvalIO HValueRef
fhv) IO (EvalResult ()) -> (EvalResult () -> IO ()) -> IO ()
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 :: HscEnv -> ForeignHValue -> IO String
evalString :: HscEnv -> ForeignHValue -> IO String
evalString hsc_env :: HscEnv
hsc_env fhv :: ForeignHValue
fhv = do
  IO String -> IO String
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
$ \fhv :: HValueRef
fhv ->
    HscEnv -> Message (EvalResult String) -> IO (EvalResult String)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (HValueRef -> Message (EvalResult String)
EvalString HValueRef
fhv) IO (EvalResult String)
-> (EvalResult String -> IO String) -> IO String
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 :: HscEnv -> ForeignHValue -> String -> IO String
evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
evalStringToIOString hsc_env :: HscEnv
hsc_env fhv :: ForeignHValue
fhv str :: String
str = do
  IO String -> IO String
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
$ \fhv :: HValueRef
fhv ->
    HscEnv -> Message (EvalResult String) -> IO (EvalResult String)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (HValueRef -> String -> Message (EvalResult String)
EvalStringToString HValueRef
fhv String
str) IO (EvalResult String)
-> (EvalResult String -> IO String) -> IO String
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 :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData hsc_env :: HscEnv
hsc_env bs :: ByteString
bs = HscEnv -> Message (RemotePtr ()) -> IO (RemotePtr ())
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (ByteString -> Message (RemotePtr ())
MallocData ByteString
bs)

mkCostCentres
  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
mkCostCentres :: HscEnv -> String -> [(String, String)] -> IO [RemotePtr CostCentre]
mkCostCentres hsc_env :: HscEnv
hsc_env mod :: String
mod ccs :: [(String, String)]
ccs =
  HscEnv
-> Message [RemotePtr CostCentre] -> IO [RemotePtr CostCentre]
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (String -> [(String, String)] -> Message [RemotePtr CostCentre]
MkCostCentres String
mod [(String, String)]
ccs)

-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
createBCOs hsc_env :: HscEnv
hsc_env rbcos :: [ResolvedBCO]
rbcos = do
  Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
              Nothing -> IO Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
              Just n :: Int
n  -> Int -> IO Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1)
    then
      HscEnv -> Message [HValueRef] -> IO [HValueRef]
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env ([ByteString] -> Message [HValueRef]
CreateBCOs [Put -> ByteString
runPut ([ResolvedBCO] -> Put
forall t. Binary t => t -> Put
put [ResolvedBCO]
rbcos)])

    else do
      Int
old_caps <- IO Int
getNumCapabilities
      if Int
old_caps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_jobs
         then IO [ByteString] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [ByteString] -> IO ()) -> IO [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO [ByteString]
forall a. a -> IO a
evaluate [ByteString]
puts
         else IO () -> IO () -> IO () -> IO ()
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)
                       (IO [ByteString] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [ByteString] -> IO ()) -> IO [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO [ByteString]
forall a. a -> IO a
evaluate [ByteString]
puts)
      HscEnv -> Message [HValueRef] -> IO [HValueRef]
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env ([ByteString] -> Message [HValueRef]
CreateBCOs [ByteString]
puts)
 where
  puts :: [ByteString]
puts = ([ResolvedBCO] -> ByteString) -> [[ResolvedBCO]] -> [ByteString]
forall a a. (a -> a) -> [a] -> [a]
parMap [ResolvedBCO] -> ByteString
forall t. Binary t => t -> ByteString
doChunk (Int -> [ResolvedBCO] -> [[ResolvedBCO]]
forall a. Int -> [a] -> [[a]]
chunkList 100 [ResolvedBCO]
rbcos)

  -- make sure we force the whole lazy ByteString
  doChunk :: t -> ByteString
doChunk c :: 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 :: (a -> a) -> [a] -> [a]
parMap _ [] = []
  parMap f :: a -> a
f (x :: a
x:xs :: [a]
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 = a -> a
f a
x; fxs :: [a]
fxs = (a -> a) -> [a] -> [a]
parMap a -> a
f [a]
xs

addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry hsc_env :: HscEnv
hsc_env fpr :: Fingerprint
fpr ref :: 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
$ \val :: HValueRef
val ->
    HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (Fingerprint -> HValueRef -> Message ()
AddSptEntry Fingerprint
fpr HValueRef
val)

costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
costCentreStackInfo hsc_env :: HscEnv
hsc_env ccs :: RemotePtr CostCentreStack
ccs =
  HscEnv -> Message [String] -> IO [String]
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (RemotePtr CostCentreStack -> Message [String]
CostCentreStackInfo RemotePtr CostCentreStack
ccs)

newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
newBreakArray hsc_env :: HscEnv
hsc_env size :: Int
size = do
  RemoteRef BreakArray
breakArray <- HscEnv
-> Message (RemoteRef BreakArray) -> IO (RemoteRef BreakArray)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (Int -> Message (RemoteRef BreakArray)
NewBreakArray Int
size)
  HscEnv -> RemoteRef BreakArray -> IO (ForeignRef BreakArray)
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env RemoteRef BreakArray
breakArray

enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
enableBreakpoint hsc_env :: HscEnv
hsc_env ref :: ForeignRef BreakArray
ref ix :: Int
ix b :: Bool
b = do
  ForeignRef BreakArray -> (RemoteRef BreakArray -> IO ()) -> IO ()
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
ref ((RemoteRef BreakArray -> IO ()) -> IO ())
-> (RemoteRef BreakArray -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \breakarray :: RemoteRef BreakArray
breakarray ->
    HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (RemoteRef BreakArray -> Int -> Bool -> Message ()
EnableBreakpoint RemoteRef BreakArray
breakarray Int
ix Bool
b)

breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus hsc_env :: HscEnv
hsc_env ref :: ForeignRef BreakArray
ref ix :: Int
ix = do
  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
$ \breakarray :: RemoteRef BreakArray
breakarray ->
    HscEnv -> Message Bool -> IO Bool
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (RemoteRef BreakArray -> Int -> Message Bool
BreakpointStatus RemoteRef BreakArray
breakarray Int
ix)

getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar hsc_env :: HscEnv
hsc_env ref :: ForeignHValue
ref ix :: Int
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
$ \apStack :: HValueRef
apStack -> do
    Maybe HValueRef
mb <- HscEnv -> Message (Maybe HValueRef) -> IO (Maybe HValueRef)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (HValueRef -> Int -> Message (Maybe HValueRef)
GetBreakpointVar HValueRef
apStack Int
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)
mapM (HscEnv -> HValueRef -> IO ForeignHValue
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env) Maybe HValueRef
mb

getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
getClosure hsc_env :: HscEnv
hsc_env ref :: 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
$ \hval :: HValueRef
hval -> do
    GenClosure HValueRef
mb <- HscEnv
-> Message (GenClosure HValueRef) -> IO (GenClosure HValueRef)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (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)
mapM (HscEnv -> HValueRef -> IO ForeignHValue
forall a. HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv
hsc_env) GenClosure HValueRef
mb

seqHValue :: HscEnv -> ForeignHValue -> IO ()
seqHValue :: HscEnv -> ForeignHValue -> IO ()
seqHValue hsc_env :: HscEnv
hsc_env ref :: 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
$ \hval :: HValueRef
hval ->
    HscEnv -> Message (EvalResult ()) -> IO (EvalResult ())
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (HValueRef -> Message (EvalResult ())
Seq HValueRef
hval) IO (EvalResult ()) -> (EvalResult () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EvalResult () -> IO ()
forall a. EvalResult a -> IO a
fromEvalResult

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

initObjLinker :: HscEnv -> IO ()
initObjLinker :: HscEnv -> IO ()
initObjLinker hsc_env :: HscEnv
hsc_env = HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env Message ()
InitLinker

lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol hsc_env :: HscEnv
hsc_env@HscEnv{..} str :: FastString
str
 | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
hsc_dflags =
     -- 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.
     HscEnv -> (IServ -> IO (Maybe (Ptr ()))) -> IO (Maybe (Ptr ()))
forall (m :: * -> *) a.
(MonadIO m, ExceptionMonad m) =>
HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv
hsc_env ((IServ -> IO (Maybe (Ptr ()))) -> IO (Maybe (Ptr ())))
-> (IServ -> IO (Maybe (Ptr ()))) -> IO (Maybe (Ptr ()))
forall a b. (a -> b) -> a -> b
$ \iserv :: IServ
iserv@IServ{..} -> do
       UniqFM (Ptr ())
cache <- IORef (UniqFM (Ptr ())) -> IO (UniqFM (Ptr ()))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Ptr ()))
iservLookupSymbolCache
       case UniqFM (Ptr ()) -> FastString -> Maybe (Ptr ())
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Ptr ())
cache FastString
str of
         Just p :: Ptr ()
p -> Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
p)
         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
$
                    IServ
-> Message (Maybe (RemotePtr ())) -> IO (Maybe (RemotePtr ()))
forall a. Binary a => IServ -> Message a -> IO a
iservCall IServ
iserv (String -> Message (Maybe (RemotePtr ()))
LookupSymbol (FastString -> String
unpackFS FastString
str))
           case Maybe (RemotePtr ())
m of
             Nothing -> Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr ())
forall a. Maybe a
Nothing
             Just r :: RemotePtr ()
r -> do
               let p :: Ptr ()
p = RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
r
               IORef (UniqFM (Ptr ())) -> UniqFM (Ptr ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Ptr ()))
iservLookupSymbolCache (UniqFM (Ptr ()) -> IO ()) -> UniqFM (Ptr ()) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Ptr ()) -> FastString -> Ptr () -> UniqFM (Ptr ())
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Ptr ())
cache FastString
str Ptr ()
p
               Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
p)
 | Bool
otherwise =
#if defined(GHCI)
   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#else
   IO (Maybe (Ptr ()))
forall a. IO a
needExtInt
#endif

lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
lookupClosure hsc_env :: HscEnv
hsc_env str :: String
str =
  HscEnv -> Message (Maybe HValueRef) -> IO (Maybe HValueRef)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (String -> Message (Maybe HValueRef)
LookupClosure String
str)

purgeLookupSymbolCache :: HscEnv -> IO ()
purgeLookupSymbolCache :: HscEnv -> IO ()
purgeLookupSymbolCache hsc_env :: HscEnv
hsc_env@HscEnv{..} =
 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
hsc_dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
   HscEnv -> (IServ -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, ExceptionMonad m) =>
HscEnv -> (IServ -> m a) -> m a
withIServ HscEnv
hsc_env ((IServ -> IO ()) -> IO ()) -> (IServ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IServ{..} ->
     IORef (UniqFM (Ptr ())) -> UniqFM (Ptr ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Ptr ()))
iservLookupSymbolCache UniqFM (Ptr ())
forall elt. UniqFM 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 :: HscEnv -> String -> IO (Maybe String)
loadDLL :: HscEnv -> String -> IO (Maybe String)
loadDLL hsc_env :: HscEnv
hsc_env str :: String
str = HscEnv -> Message (Maybe String) -> IO (Maybe String)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (String -> Message (Maybe String)
LoadDLL String
str)

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

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

unloadObj :: HscEnv -> String -> IO ()
unloadObj :: HscEnv -> String -> IO ()
unloadObj hsc_env :: HscEnv
hsc_env path :: String
path = do
  String
path' <- String -> IO String
canonicalizePath String
path -- Note [loadObj and relative paths]
  HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (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 :: HscEnv -> String -> IO (Ptr ())
addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
addLibrarySearchPath hsc_env :: HscEnv
hsc_env str :: 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
<$> HscEnv -> Message (RemotePtr ()) -> IO (RemotePtr ())
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (String -> Message (RemotePtr ())
AddLibrarySearchPath String
str)

removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
removeLibrarySearchPath hsc_env :: HscEnv
hsc_env p :: Ptr ()
p =
  HscEnv -> Message Bool -> IO Bool
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (RemotePtr () -> Message Bool
RemoveLibrarySearchPath (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))

resolveObjs :: HscEnv -> IO SuccessFlag
resolveObjs :: HscEnv -> IO SuccessFlag
resolveObjs hsc_env :: HscEnv
hsc_env = Bool -> SuccessFlag
successIf (Bool -> SuccessFlag) -> IO Bool -> IO SuccessFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Message Bool -> IO Bool
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env Message Bool
ResolveObjs

findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
findSystemLibrary hsc_env :: HscEnv
hsc_env str :: String
str = HscEnv -> Message (Maybe String) -> IO (Maybe String)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (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 => IServ -> Message a -> IO a
iservCall :: IServ -> Message a -> IO a
iservCall iserv :: IServ
iserv@IServ{..} msg :: Message a
msg =
  Pipe -> Message a -> IO a
forall a. Binary a => Pipe -> Message a -> IO a
remoteCall Pipe
iservPipe Message a
msg
    IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> IServ -> SomeException -> IO a
forall a. IServ -> SomeException -> IO a
handleIServFailure IServ
iserv SomeException
e

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

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

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

-- -----------------------------------------------------------------------------
-- Starting and stopping the iserv process

startIServ :: DynFlags -> IO IServ
startIServ :: DynFlags -> IO IServ
startIServ dflags :: DynFlags
dflags = do
  let flavour :: String
flavour
        | Way
WayProf Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags = "-prof"
        | Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags = "-dyn"
        | Bool
otherwise = ""
      prog :: String
prog = DynFlags -> String
pgm_i DynFlags
dflags String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flavour
      opts :: [String]
opts = DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_i
  DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (MsgDoc -> IO ()) -> MsgDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Starting " MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
prog
  let createProc :: CreateProcess -> IO ProcessHandle
createProc = (Hooks -> Maybe (CreateProcess -> IO ProcessHandle))
-> (CreateProcess -> IO ProcessHandle)
-> DynFlags
-> CreateProcess
-> IO ProcessHandle
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks -> Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook
                              (\cp :: CreateProcess
cp -> do { (_,_,_,ph :: ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
                                         ; ProcessHandle -> IO ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
ph })
                              DynFlags
dflags
  (ph :: ProcessHandle
ph, rh :: Handle
rh, wh :: Handle
wh) <- (CreateProcess -> IO ProcessHandle)
-> String -> [String] -> IO (ProcessHandle, Handle, Handle)
runWithPipes CreateProcess -> IO ProcessHandle
createProc String
prog [String]
opts
  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
  IORef (UniqFM (Ptr ()))
cache_ref <- UniqFM (Ptr ()) -> IO (IORef (UniqFM (Ptr ())))
forall a. a -> IO (IORef a)
newIORef UniqFM (Ptr ())
forall elt. UniqFM elt
emptyUFM
  IServ -> IO IServ
forall (m :: * -> *) a. Monad m => a -> m a
return (IServ -> IO IServ) -> IServ -> IO IServ
forall a b. (a -> b) -> a -> b
$ IServ :: Pipe
-> ProcessHandle -> IORef (UniqFM (Ptr ())) -> [HValueRef] -> IServ
IServ
    { iservPipe :: Pipe
iservPipe = Pipe :: Handle -> Handle -> IORef (Maybe ByteString) -> Pipe
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 :: IORef (UniqFM (Ptr ()))
iservLookupSymbolCache = IORef (UniqFM (Ptr ()))
cache_ref
    , iservPendingFrees :: [HValueRef]
iservPendingFrees = []
    }

stopIServ :: HscEnv -> IO ()
stopIServ :: HscEnv -> IO ()
stopIServ HscEnv{..} =
  ((IO Any -> IO Any) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
ExceptionMonad m =>
((m a -> m a) -> m b) -> m b
gmask (((IO Any -> IO Any) -> IO ()) -> IO ())
-> ((IO Any -> IO Any) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_restore :: IO Any -> IO Any
_restore -> do
    Maybe IServ
m <- MVar (Maybe IServ) -> IO (Maybe IServ)
forall a. MVar a -> IO a
takeMVar MVar (Maybe IServ)
hsc_iserv
    IO () -> (IServ -> IO ()) -> Maybe IServ -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IServ -> IO ()
stop Maybe IServ
m
    MVar (Maybe IServ) -> Maybe IServ -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe IServ)
hsc_iserv Maybe IServ
forall a. Maybe a
Nothing
 where
  stop :: IServ -> IO ()
stop iserv :: IServ
iserv = do
    Maybe ExitCode
ex <- ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode (IServ -> ProcessHandle
iservProcess IServ
iserv)
    if Maybe ExitCode -> Bool
forall a. Maybe a -> Bool
isJust Maybe ExitCode
ex
       then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       else IServ -> Message () -> IO ()
forall a. Binary a => IServ -> Message a -> IO a
iservCall IServ
iserv Message ()
Shutdown

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) `onException` (c__close fd)

#else
runWithPipes :: (CreateProcess -> IO ProcessHandle)
-> String -> [String] -> IO (ProcessHandle, Handle, Handle)
runWithPipes createProc :: CreateProcess -> IO ProcessHandle
createProc prog :: String
prog opts :: [String]
opts = do
    (rfd1 :: Fd
rfd1, wfd1 :: Fd
wfd1) <- IO (Fd, Fd)
Posix.createPipe -- we read on rfd1
    (rfd2 :: Fd
rfd2, wfd2 :: 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 = Fd -> String
forall a. Show a => a -> String
show Fd
wfd1 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Fd -> String
forall a. Show a => a -> String
show Fd
rfd2 String -> [String] -> [String]
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
    (ProcessHandle, Handle, Handle)
-> IO (ProcessHandle, Handle, Handle)
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 iservCmd will free any RemoteRefs in
the list.  It was done this way rather than calling iservCmd directly,
because I didn't want to have arbitrary threads calling iservCmd.  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 :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv{..} rref :: RemoteRef a
rref = RemoteRef a -> IO () -> IO (ForeignRef a)
forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef RemoteRef a
rref IO ()
free
 where
  !external :: Bool
external = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
hsc_dflags
  hvref :: HValueRef
hvref = RemoteRef a -> HValueRef
forall a. RemoteRef a -> HValueRef
toHValueRef RemoteRef a
rref

  free :: IO ()
  free :: IO ()
free
    | Bool -> Bool
not Bool
external = HValueRef -> IO ()
forall a. RemoteRef a -> IO ()
freeRemoteRef HValueRef
hvref
    | Bool
otherwise =
      MVar (Maybe IServ) -> (Maybe IServ -> IO (Maybe IServ)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe IServ)
hsc_iserv ((Maybe IServ -> IO (Maybe IServ)) -> IO ())
-> (Maybe IServ -> IO (Maybe IServ)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \mb_iserv :: Maybe IServ
mb_iserv ->
        case Maybe IServ
mb_iserv of
          Nothing -> Maybe IServ -> IO (Maybe IServ)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IServ
forall a. Maybe a
Nothing -- already shut down
          Just iserv :: IServ
iserv@IServ{..} ->
            Maybe IServ -> IO (Maybe IServ)
forall (m :: * -> *) a. Monad m => a -> m a
return (IServ -> Maybe IServ
forall a. a -> Maybe a
Just IServ
iserv{iservPendingFrees :: [HValueRef]
iservPendingFrees = HValueRef
hvref HValueRef -> [HValueRef] -> [HValueRef]
forall a. a -> [a] -> [a]
: [HValueRef]
iservPendingFrees})

freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
freeHValueRefs _ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeHValueRefs hsc_env :: HscEnv
hsc_env refs :: [HValueRef]
refs = HscEnv -> Message () -> IO ()
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env ([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 :: DynFlags -> ForeignRef a -> IO a
wormhole :: DynFlags -> ForeignRef a -> IO a
wormhole dflags :: DynFlags
dflags r :: ForeignRef a
r = DynFlags -> RemoteRef a -> IO a
forall a. DynFlags -> RemoteRef a -> IO a
wormholeRef DynFlags
dflags (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 :: DynFlags -> RemoteRef a -> IO a
wormholeRef :: DynFlags -> RemoteRef a -> IO a
wormholeRef dflags :: DynFlags
dflags _r :: RemoteRef a
_r
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags
  = GhcException -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError
      "this operation requires -fno-external-interpreter")
#if defined(GHCI)
  | otherwise
  = localRef _r
#else
  | Bool
otherwise
  = GhcException -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> GhcException
InstallationError
      "can't wormhole a value in a stage1 compiler")
#endif

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

mkEvalOpts :: DynFlags -> Bool -> EvalOpts
mkEvalOpts :: DynFlags -> Bool -> EvalOpts
mkEvalOpts dflags :: DynFlags
dflags step :: Bool
step =
  EvalOpts :: Bool -> Bool -> Bool -> Bool -> EvalOpts
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 :: EvalResult a -> IO a
fromEvalResult (EvalException e :: SerializableException
e) = SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SerializableException -> SomeException
fromSerializableException SerializableException
e)
fromEvalResult (EvalSuccess a :: a
a) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a