GHCi.hs 22.1 KB
Newer Older
1 2 3 4 5 6 7 8
{-# 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
9
    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
10 11 12 13 14 15
  , resumeStmt
  , abandonStmt
  , evalIO
  , evalString
  , evalStringToIOString
  , mallocData
16
  , createBCOs
17
  , addSptEntry
18
  , mkCostCentres
19
  , costCentreStackInfo
20 21 22
  , newBreakArray
  , enableBreakpoint
  , breakpointStatus
23
  , getBreakpointVar
24 25
  , getClosure
  , seqHValue
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50

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

51 52
import GhcPrelude

53
import GHCi.Message
Ben Gamari's avatar
Ben Gamari committed
54
#if defined(GHCI)
55
import GHCi.Run
56
#endif
57
import GHCi.RemoteTypes
58
import GHCi.ResolvedBCO
59
import GHCi.BreakArray (BreakArray)
60
import Fingerprint
61 62 63 64 65 66 67 68 69
import HscTypes
import UniqFM
import Panic
import DynFlags
import ErrUtils
import Outputable
import Exception
import BasicTypes
import FastString
70
import Util
71
import Hooks
72 73 74 75 76

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Binary
77
import Data.Binary.Put
78
import Data.ByteString (ByteString)
79
import qualified Data.ByteString.Lazy as LB
80
import Data.IORef
81
import Foreign hiding (void)
82
import GHC.Exts.Heap
83
import GHC.Stack.CCS (CostCentre,CostCentreStack)
84 85
import System.Exit
import Data.Maybe
Tamar Christina's avatar
Tamar Christina committed
86
import GHC.IO.Handle.Types (Handle)
Ben Gamari's avatar
Ben Gamari committed
87
#if defined(mingw32_HOST_OS)
thomie's avatar
thomie committed
88
import Foreign.C
Tamar Christina's avatar
Tamar Christina committed
89 90
import GHC.IO.Handle.FD (fdToHandle)
#else
91 92
import System.Posix as Posix
#endif
93
import System.Directory
94
import System.Process
Ben Gamari's avatar
Ben Gamari committed
95
import GHC.Conc (getNumProcessors, pseq, par)
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119

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

120
For other reasons see remote-GHCi on the wiki.
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150

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.
Simon Marlow's avatar
Simon Marlow committed
151 152 153 154

Other Notes on Remote GHCi
~~~~~~~~~~~~~~~~~~~~~~~~~~
  * This wiki page has an implementation overview:
155
    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter
Simon Marlow's avatar
Simon Marlow committed
156 157
  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
158 159
-}

Ben Gamari's avatar
Ben Gamari committed
160
#if !defined(GHCI)
161 162 163 164 165
needExtInt :: IO a
needExtInt = throwIO
  (InstallationError "this operation requires -fexternal-interpreter")
#endif

166 167 168 169 170 171 172 173 174 175 176 177
-- | 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 hsc_env@HscEnv{..} msg
 | gopt Opt_ExternalInterpreter hsc_dflags =
     withIServ hsc_env $ \iserv ->
       uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
         iservCall iserv msg
 | otherwise = -- Just run it directly
Ben Gamari's avatar
Ben Gamari committed
178
#if defined(GHCI)
179
   run msg
180 181 182
#else
   needExtInt
#endif
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221

-- 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{..} action =
  gmask $ \restore -> do
    m <- liftIO $ takeMVar hsc_iserv
      -- start the iserv process if we haven't done so yet
    iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
               `gonException` (liftIO $ putMVar hsc_iserv Nothing)
      -- free any ForeignHValues that have been garbage collected.
    let iserv' = iserv{ iservPendingFrees = [] }
    a <- (do
      liftIO $ when (not (null (iservPendingFrees iserv))) $
        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
        -- run the inner action
      restore $ action iserv)
          `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
    liftIO $ putMVar hsc_iserv (Just iserv')
    return a


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

-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
-- each of the results.
evalStmt
222 223
  :: HscEnv -> Bool -> EvalExpr ForeignHValue
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
224 225 226 227 228 229 230 231
evalStmt hsc_env step foreign_expr = do
  let dflags = hsc_dflags hsc_env
  status <- withExpr foreign_expr $ \expr ->
    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
  handleEvalStatus hsc_env status
 where
  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
  withExpr (EvalThis fhv) cont =
232
    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
233 234 235 236 237
  withExpr (EvalApp fl fr) cont =
    withExpr fl $ \fl' ->
    withExpr fr $ \fr' ->
    cont (EvalApp fl' fr')

238 239 240
resumeStmt
  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
241 242
resumeStmt hsc_env step resume_ctxt = do
  let dflags = hsc_dflags hsc_env
243
  status <- withForeignRef resume_ctxt $ \rhv ->
244 245 246
    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
  handleEvalStatus hsc_env status

247
abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
248
abandonStmt hsc_env resume_ctxt = do
249
  withForeignRef resume_ctxt $ \rhv ->
250 251 252
    iservCmd hsc_env (AbandonStmt rhv)

handleEvalStatus
253 254
  :: HscEnv -> EvalStatus [HValueRef]
  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
255 256
handleEvalStatus hsc_env status =
  case status of
257
    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
258 259 260 261 262 263 264 265 266 267
    EvalComplete alloc res ->
      EvalComplete alloc <$> addFinalizer res
 where
  addFinalizer (EvalException e) = return (EvalException e)
  addFinalizer (EvalSuccess rs) = do
    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs

-- | Execute an action of type @IO ()@
evalIO :: HscEnv -> ForeignHValue -> IO ()
evalIO hsc_env fhv = do
268
  liftIO $ withForeignRef fhv $ \fhv ->
269 270 271 272 273
    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult

-- | Execute an action of type @IO String@
evalString :: HscEnv -> ForeignHValue -> IO String
evalString hsc_env fhv = do
274
  liftIO $ withForeignRef fhv $ \fhv ->
275 276 277 278 279
    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult

-- | Execute an action of type @String -> IO String@
evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
evalStringToIOString hsc_env fhv str = do
280
  liftIO $ withForeignRef fhv $ \fhv ->
281 282 283 284 285
    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult


-- | Allocate and store the given bytes in memory, returning a pointer
-- to the memory in the remote process.
286 287
mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
288

289 290 291 292
mkCostCentres
  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
mkCostCentres hsc_env mod ccs =
  iservCmd hsc_env (MkCostCentres mod ccs)
293

294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
createBCOs hsc_env rbcos = do
  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
              Nothing -> liftIO getNumProcessors
              Just n  -> return n
  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
  -- (-j<n>) parallelise the serialization.
  if (n_jobs == 1)
    then
      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])

    else do
      old_caps <- getNumCapabilities
      if old_caps == n_jobs
         then void $ evaluate puts
         else bracket_ (setNumCapabilities n_jobs)
                       (setNumCapabilities old_caps)
                       (void $ evaluate puts)
      iservCmd hsc_env (CreateBCOs puts)
 where
  puts = parMap doChunk (chunkList 100 rbcos)

  -- make sure we force the whole lazy ByteString
  doChunk c = pseq (LB.length bs) bs
    where bs = runPut (put c)

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

326 327 328 329 330
addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry hsc_env fpr ref =
  withForeignRef ref $ \val ->
    iservCmd hsc_env (AddSptEntry fpr val)

331
costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
332 333
costCentreStackInfo hsc_env ccs =
  iservCmd hsc_env (CostCentreStackInfo ccs)
334

335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
newBreakArray hsc_env size = do
  breakArray <- iservCmd hsc_env (NewBreakArray size)
  mkFinalizedHValue hsc_env breakArray

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

breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
breakpointStatus hsc_env ref ix = do
  withForeignRef ref $ \breakarray ->
    iservCmd hsc_env (BreakpointStatus breakarray ix)

350 351 352 353 354
getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
getBreakpointVar hsc_env ref ix =
  withForeignRef ref $ \apStack -> do
    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
    mapM (mkFinalizedHValue hsc_env) mb
355

356 357 358 359 360 361 362 363 364 365 366
getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
getClosure hsc_env ref =
  withForeignRef ref $ \hval -> do
    mb <- iservCmd hsc_env (GetClosure hval)
    mapM (mkFinalizedHValue hsc_env) mb

seqHValue :: HscEnv -> ForeignHValue -> IO ()
seqHValue hsc_env ref =
  withForeignRef ref $ \hval ->
    iservCmd hsc_env (Seq hval) >>= fromEvalResult

367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker

initObjLinker :: HscEnv -> IO ()
initObjLinker hsc_env = iservCmd hsc_env InitLinker

lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol hsc_env@HscEnv{..} str
 | gopt Opt_ExternalInterpreter 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.
     withIServ hsc_env $ \iserv@IServ{..} -> do
       cache <- readIORef iservLookupSymbolCache
       case lookupUFM cache str of
         Just p -> return (Just p)
         Nothing -> do
           m <- uninterruptibleMask_ $
                    iservCall iserv (LookupSymbol (unpackFS str))
           case m of
             Nothing -> return Nothing
             Just r -> do
               let p = fromRemotePtr r
               writeIORef iservLookupSymbolCache $! addToUFM cache str p
               return (Just p)
 | otherwise =
Ben Gamari's avatar
Ben Gamari committed
394
#if defined(GHCI)
395
   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
396 397 398
#else
   needExtInt
#endif
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424

lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
lookupClosure hsc_env str =
  iservCmd hsc_env (LookupClosure str)

purgeLookupSymbolCache :: HscEnv -> IO ()
purgeLookupSymbolCache hsc_env@HscEnv{..} =
 when (gopt Opt_ExternalInterpreter hsc_dflags) $
   withIServ hsc_env $ \IServ{..} ->
     writeIORef iservLookupSymbolCache 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 hsc_env str = iservCmd hsc_env (LoadDLL str)

loadArchive :: HscEnv -> String -> IO ()
425 426 427
loadArchive hsc_env path = do
  path' <- canonicalizePath path -- Note [loadObj and relative paths]
  iservCmd hsc_env (LoadArchive path')
428 429

loadObj :: HscEnv -> String -> IO ()
430 431 432
loadObj hsc_env path = do
  path' <- canonicalizePath path -- Note [loadObj and relative paths]
  iservCmd hsc_env (LoadObj path')
433 434

unloadObj :: HscEnv -> String -> IO ()
435 436 437 438 439 440 441 442
unloadObj hsc_env path = do
  path' <- canonicalizePath path -- Note [loadObj and relative paths]
  iservCmd hsc_env (UnloadObj path')

-- Note [loadObj and relative paths]
-- the iserv process might have a different current directory from the
-- GHC process, so we must make paths absolute before sending them
-- over.
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502

addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
addLibrarySearchPath hsc_env str =
  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)

removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
removeLibrarySearchPath hsc_env p =
  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))

resolveObjs :: HscEnv -> IO SuccessFlag
resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs

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

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

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

handleIServFailure :: IServ -> SomeException -> IO a
handleIServFailure IServ{..} e = do
  ex <- getProcessExitCode iservProcess
  case ex of
    Just (ExitFailure n) ->
      throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
    _ -> do
      terminateProcess iservProcess
      _ <- waitForProcess iservProcess
      throw e

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

startIServ :: DynFlags -> IO IServ
startIServ dflags = do
  let flavour
        | WayProf `elem` ways dflags = "-prof"
        | WayDyn `elem` ways dflags = "-dyn"
        | otherwise = ""
      prog = pgm_i dflags ++ flavour
      opts = getOpts dflags opt_i
  debugTraceMsg dflags 3 $ text "Starting " <> text prog
503 504 505 506 507
  let createProc = lookupHook createIservProcessHook
                              (\cp -> do { (_,_,_,ph) <- createProcess cp
                                         ; return ph })
                              dflags
  (ph, rh, wh) <- runWithPipes createProc prog opts
508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530
  lo_ref <- newIORef Nothing
  cache_ref <- newIORef emptyUFM
  return $ IServ
    { iservPipe = Pipe { pipeRead = rh
                       , pipeWrite = wh
                       , pipeLeftovers = lo_ref }
    , iservProcess = ph
    , iservLookupSymbolCache = cache_ref
    , iservPendingFrees = []
    }

stopIServ :: HscEnv -> IO ()
stopIServ HscEnv{..} =
  gmask $ \_restore -> do
    m <- takeMVar hsc_iserv
    maybe (return ()) stop m
    putMVar hsc_iserv Nothing
 where
  stop iserv = do
    ex <- getProcessExitCode (iservProcess iserv)
    if isJust ex
       then return ()
       else iservCall iserv Shutdown
Tamar Christina's avatar
Tamar Christina committed
531

532 533
runWithPipes :: (CreateProcess -> IO ProcessHandle)
             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
Ben Gamari's avatar
Ben Gamari committed
534
#if defined(mingw32_HOST_OS)
Tamar Christina's avatar
Tamar Christina committed
535 536 537 538 539 540
foreign import ccall "io.h _close"
   c__close :: CInt -> IO CInt

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

541
runWithPipes createProc prog opts = do
Tamar Christina's avatar
Tamar Christina committed
542 543 544 545 546
    (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
547
    ph <- createProc (proc prog args)
Tamar Christina's avatar
Tamar Christina committed
548 549 550 551 552
    rh <- mkHandle rfd1
    wh <- mkHandle wfd2
    return (ph, rh, wh)
      where mkHandle :: CInt -> IO Handle
            mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
553

Tamar Christina's avatar
Tamar Christina committed
554
#else
555
runWithPipes createProc prog opts = do
Tamar Christina's avatar
Tamar Christina committed
556 557 558 559 560
    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
    setFdOption rfd1 CloseOnExec True
    setFdOption wfd2 CloseOnExec True
    let args = show wfd1 : show rfd2 : opts
561
    ph <- createProc (proc prog args)
Tamar Christina's avatar
Tamar Christina committed
562 563 564 565 566
    closeFd wfd1
    closeFd rfd2
    rh <- fdToHandle rfd1
    wh <- fdToHandle wfd2
    return (ph, rh, wh)
567 568 569 570 571 572 573 574 575 576
#endif

-- -----------------------------------------------------------------------------
{- Note [External GHCi pointers]

We have the following ways to reference things in GHCi:

HValue
------

Gabor Greif's avatar
Gabor Greif committed
577
HValue is a direct reference to a value in the local heap.  Obviously
578 579 580
we cannot use this to refer to things in the external process.


581
RemoteRef
582 583
---------

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

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

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

595 596
ForeignRef
----------
597

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

602 603
The finalizer adds the RemoteRef to the iservPendingFrees list in the
IServ record.  The next call to iservCmd will free any RemoteRefs in
604 605 606 607 608
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.
-}

609 610
-- | Creates a 'ForeignRef' that will automatically release the
-- 'RemoteRef' when it is no longer referenced.
611 612
mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
613 614
 where
  !external = gopt Opt_ExternalInterpreter hsc_dflags
615
  hvref = toHValueRef rref
616 617 618

  free :: IO ()
  free
619
    | not external = freeRemoteRef hvref
620 621 622 623 624 625 626 627 628 629 630
    | otherwise =
      modifyMVar_ hsc_iserv $ \mb_iserv ->
        case mb_iserv of
          Nothing -> return Nothing -- already shut down
          Just iserv@IServ{..} ->
            return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})

freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
freeHValueRefs _ [] = return ()
freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)

631 632 633
-- | 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.
634 635
wormhole :: DynFlags -> ForeignRef a -> IO a
wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
636

637 638 639
-- | 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.
640
wormholeRef :: DynFlags -> RemoteRef a -> IO a
Richard Eisenberg's avatar
Richard Eisenberg committed
641
wormholeRef dflags _r
642 643 644
  | gopt Opt_ExternalInterpreter dflags
  = throwIO (InstallationError
      "this operation requires -fno-external-interpreter")
Ben Gamari's avatar
Ben Gamari committed
645
#if defined(GHCI)
646
  | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
647
  = localRef _r
648 649 650 651 652
#else
  | otherwise
  = throwIO (InstallationError
      "can't wormhole a value in a stage1 compiler")
#endif
653 654 655 656 657 658 659 660 661 662 663 664 665 666 667

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

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

fromEvalResult :: EvalResult a -> IO a
fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
fromEvalResult (EvalSuccess a) = return a