Add hook for creating ghci external interpreter
[ghc.git] / compiler / ghci / GHCi.hs
1 {-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
2
3 --
4 -- | Interacting with the interpreter, whether it is running on an
5 -- external process or in the current process.
6 --
7 module GHCi
8 ( -- * High-level interface to the interpreter
9 evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
10 , resumeStmt
11 , abandonStmt
12 , evalIO
13 , evalString
14 , evalStringToIOString
15 , mallocData
16 , createBCOs
17 , mkCostCentres
18 , costCentreStackInfo
19 , newBreakArray
20 , enableBreakpoint
21 , breakpointStatus
22 , getBreakpointVar
23
24 -- * The object-code linker
25 , initObjLinker
26 , lookupSymbol
27 , lookupClosure
28 , loadDLL
29 , loadArchive
30 , loadObj
31 , unloadObj
32 , addLibrarySearchPath
33 , removeLibrarySearchPath
34 , resolveObjs
35 , findSystemLibrary
36
37 -- * Lower-level API using messages
38 , iservCmd, Message(..), withIServ, stopIServ
39 , iservCall, readIServ, writeIServ
40 , purgeLookupSymbolCache
41 , freeHValueRefs
42 , mkFinalizedHValue
43 , wormhole, wormholeRef
44 , mkEvalOpts
45 , fromEvalResult
46 ) where
47
48 import GHCi.Message
49 import GHCi.Run
50 import GHCi.RemoteTypes
51 import GHCi.ResolvedBCO
52 import GHCi.BreakArray (BreakArray)
53 import HscTypes
54 import UniqFM
55 import Panic
56 import DynFlags
57 import ErrUtils
58 import Outputable
59 import Exception
60 import BasicTypes
61 import FastString
62 import Util
63 import Hooks
64
65 import Control.Concurrent
66 import Control.Monad
67 import Control.Monad.IO.Class
68 import Data.Binary
69 import Data.Binary.Put
70 import Data.ByteString (ByteString)
71 import qualified Data.ByteString.Lazy as LB
72 import Data.IORef
73 import Foreign hiding (void)
74 import GHC.Stack.CCS (CostCentre,CostCentreStack)
75 import System.Exit
76 import Data.Maybe
77 import GHC.IO.Handle.Types (Handle)
78 #ifdef mingw32_HOST_OS
79 import Foreign.C
80 import GHC.IO.Handle.FD (fdToHandle)
81 #else
82 import System.Posix as Posix
83 #endif
84 import System.Process
85 import GHC.Conc (getNumProcessors, pseq, par)
86
87 {- Note [Remote GHCi]
88
89 When the flag -fexternal-interpreter is given to GHC, interpreted code
90 is run in a separate process called iserv, and we communicate with the
91 external process over a pipe using Binary-encoded messages.
92
93 Motivation
94 ~~~~~~~~~~
95
96 When the interpreted code is running in a separate process, it can
97 use a different "way", e.g. profiled or dynamic. This means
98
99 - compiling Template Haskell code with -prof does not require
100 building the code without -prof first
101
102 - when GHC itself is profiled, it can interpret unprofiled code,
103 and the same applies to dynamic linking.
104
105 - An unprofiled GHCi can load and run profiled code, which means it
106 can use the stack-trace functionality provided by profiling without
107 taking the performance hit on the compiler that profiling would
108 entail.
109
110 For other reasons see RemoteGHCi on the wiki.
111
112 Implementation Overview
113 ~~~~~~~~~~~~~~~~~~~~~~~
114
115 The main pieces are:
116
117 - libraries/ghci, containing:
118 - types for talking about remote values (GHCi.RemoteTypes)
119 - the message protocol (GHCi.Message),
120 - implementation of the messages (GHCi.Run)
121 - implementation of Template Haskell (GHCi.TH)
122 - a few other things needed to run interpreted code
123
124 - top-level iserv directory, containing the codefor the external
125 server. This is a fairly simple wrapper, most of the functionality
126 is provided by modules in libraries/ghci.
127
128 - This module (GHCi) which provides the interface to the server used
129 by the rest of GHC.
130
131 GHC works with and without -fexternal-interpreter. With the flag, all
132 interpreted code is run by the iserv binary. Without the flag,
133 interpreted code is run in the same process as GHC.
134
135 Things that do not work with -fexternal-interpreter
136 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
137
138 dynCompileExpr cannot work, because we have no way to run code of an
139 unknown type in the remote process. This API fails with an error
140 message if it is used with -fexternal-interpreter.
141
142 Other Notes on Remote GHCi
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~
144 * This wiki page has an implementation overview:
145 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter
146 * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
147 * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
148 -}
149
150 -- | Run a command in the interpreter's context. With
151 -- @-fexternal-interpreter@, the command is serialized and sent to an
152 -- external iserv process, and the response is deserialized (hence the
153 -- @Binary@ constraint). With @-fno-external-interpreter@ we execute
154 -- the command directly here.
155 iservCmd :: Binary a => HscEnv -> Message a -> IO a
156 iservCmd hsc_env@HscEnv{..} msg
157 | gopt Opt_ExternalInterpreter hsc_dflags =
158 withIServ hsc_env $ \iserv ->
159 uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
160 iservCall iserv msg
161 | otherwise = -- Just run it directly
162 run msg
163
164
165 -- Note [uninterruptibleMask_ and iservCmd]
166 --
167 -- If we receive an async exception, such as ^C, while communicating
168 -- with the iserv process then we will be out-of-sync and not be able
169 -- to recoever. Thus we use uninterruptibleMask_ during
170 -- communication. A ^C will be delivered to the iserv process (because
171 -- signals get sent to the whole process group) which will interrupt
172 -- the running computation and return an EvalException result.
173
174 -- | Grab a lock on the 'IServ' and do something with it.
175 -- Overloaded because this is used from TcM as well as IO.
176 withIServ
177 :: (MonadIO m, ExceptionMonad m)
178 => HscEnv -> (IServ -> m a) -> m a
179 withIServ HscEnv{..} action =
180 gmask $ \restore -> do
181 m <- liftIO $ takeMVar hsc_iserv
182 -- start the iserv process if we haven't done so yet
183 iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
184 `gonException` (liftIO $ putMVar hsc_iserv Nothing)
185 -- free any ForeignHValues that have been garbage collected.
186 let iserv' = iserv{ iservPendingFrees = [] }
187 a <- (do
188 liftIO $ when (not (null (iservPendingFrees iserv))) $
189 iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
190 -- run the inner action
191 restore $ action iserv)
192 `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
193 liftIO $ putMVar hsc_iserv (Just iserv')
194 return a
195
196
197 -- -----------------------------------------------------------------------------
198 -- Wrappers around messages
199
200 -- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
201 -- each of the results.
202 evalStmt
203 :: HscEnv -> Bool -> EvalExpr ForeignHValue
204 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
205 evalStmt hsc_env step foreign_expr = do
206 let dflags = hsc_dflags hsc_env
207 status <- withExpr foreign_expr $ \expr ->
208 iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
209 handleEvalStatus hsc_env status
210 where
211 withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
212 withExpr (EvalThis fhv) cont =
213 withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
214 withExpr (EvalApp fl fr) cont =
215 withExpr fl $ \fl' ->
216 withExpr fr $ \fr' ->
217 cont (EvalApp fl' fr')
218
219 resumeStmt
220 :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
221 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
222 resumeStmt hsc_env step resume_ctxt = do
223 let dflags = hsc_dflags hsc_env
224 status <- withForeignRef resume_ctxt $ \rhv ->
225 iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
226 handleEvalStatus hsc_env status
227
228 abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
229 abandonStmt hsc_env resume_ctxt = do
230 withForeignRef resume_ctxt $ \rhv ->
231 iservCmd hsc_env (AbandonStmt rhv)
232
233 handleEvalStatus
234 :: HscEnv -> EvalStatus [HValueRef]
235 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
236 handleEvalStatus hsc_env status =
237 case status of
238 EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
239 EvalComplete alloc res ->
240 EvalComplete alloc <$> addFinalizer res
241 where
242 addFinalizer (EvalException e) = return (EvalException e)
243 addFinalizer (EvalSuccess rs) = do
244 EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
245
246 -- | Execute an action of type @IO ()@
247 evalIO :: HscEnv -> ForeignHValue -> IO ()
248 evalIO hsc_env fhv = do
249 liftIO $ withForeignRef fhv $ \fhv ->
250 iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
251
252 -- | Execute an action of type @IO String@
253 evalString :: HscEnv -> ForeignHValue -> IO String
254 evalString hsc_env fhv = do
255 liftIO $ withForeignRef fhv $ \fhv ->
256 iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
257
258 -- | Execute an action of type @String -> IO String@
259 evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
260 evalStringToIOString hsc_env fhv str = do
261 liftIO $ withForeignRef fhv $ \fhv ->
262 iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
263
264
265 -- | Allocate and store the given bytes in memory, returning a pointer
266 -- to the memory in the remote process.
267 mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
268 mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
269
270 mkCostCentres
271 :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
272 mkCostCentres hsc_env mod ccs =
273 iservCmd hsc_env (MkCostCentres mod ccs)
274
275 -- | Create a set of BCOs that may be mutually recursive.
276 createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
277 createBCOs hsc_env rbcos = do
278 n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
279 Nothing -> liftIO getNumProcessors
280 Just n -> return n
281 -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
282 -- (-j<n>) parallelise the serialization.
283 if (n_jobs == 1)
284 then
285 iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
286
287 else do
288 old_caps <- getNumCapabilities
289 if old_caps == n_jobs
290 then void $ evaluate puts
291 else bracket_ (setNumCapabilities n_jobs)
292 (setNumCapabilities old_caps)
293 (void $ evaluate puts)
294 iservCmd hsc_env (CreateBCOs puts)
295 where
296 puts = parMap doChunk (chunkList 100 rbcos)
297
298 -- make sure we force the whole lazy ByteString
299 doChunk c = pseq (LB.length bs) bs
300 where bs = runPut (put c)
301
302 -- We don't have the parallel package, so roll our own simple parMap
303 parMap _ [] = []
304 parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
305 where fx = f x; fxs = parMap f xs
306
307 costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
308 costCentreStackInfo hsc_env ccs =
309 iservCmd hsc_env (CostCentreStackInfo ccs)
310
311 newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
312 newBreakArray hsc_env size = do
313 breakArray <- iservCmd hsc_env (NewBreakArray size)
314 mkFinalizedHValue hsc_env breakArray
315
316 enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
317 enableBreakpoint hsc_env ref ix b = do
318 withForeignRef ref $ \breakarray ->
319 iservCmd hsc_env (EnableBreakpoint breakarray ix b)
320
321 breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
322 breakpointStatus hsc_env ref ix = do
323 withForeignRef ref $ \breakarray ->
324 iservCmd hsc_env (BreakpointStatus breakarray ix)
325
326 getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
327 getBreakpointVar hsc_env ref ix =
328 withForeignRef ref $ \apStack -> do
329 mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
330 mapM (mkFinalizedHValue hsc_env) mb
331
332 -- -----------------------------------------------------------------------------
333 -- Interface to the object-code linker
334
335 initObjLinker :: HscEnv -> IO ()
336 initObjLinker hsc_env = iservCmd hsc_env InitLinker
337
338 lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
339 lookupSymbol hsc_env@HscEnv{..} str
340 | gopt Opt_ExternalInterpreter hsc_dflags =
341 -- Profiling of GHCi showed a lot of time and allocation spent
342 -- making cross-process LookupSymbol calls, so I added a GHC-side
343 -- cache which sped things up quite a lot. We have to be careful
344 -- to purge this cache when unloading code though.
345 withIServ hsc_env $ \iserv@IServ{..} -> do
346 cache <- readIORef iservLookupSymbolCache
347 case lookupUFM cache str of
348 Just p -> return (Just p)
349 Nothing -> do
350 m <- uninterruptibleMask_ $
351 iservCall iserv (LookupSymbol (unpackFS str))
352 case m of
353 Nothing -> return Nothing
354 Just r -> do
355 let p = fromRemotePtr r
356 writeIORef iservLookupSymbolCache $! addToUFM cache str p
357 return (Just p)
358 | otherwise =
359 fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
360
361 lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
362 lookupClosure hsc_env str =
363 iservCmd hsc_env (LookupClosure str)
364
365 purgeLookupSymbolCache :: HscEnv -> IO ()
366 purgeLookupSymbolCache hsc_env@HscEnv{..} =
367 when (gopt Opt_ExternalInterpreter hsc_dflags) $
368 withIServ hsc_env $ \IServ{..} ->
369 writeIORef iservLookupSymbolCache emptyUFM
370
371
372 -- | loadDLL loads a dynamic library using the OS's native linker
373 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
374 -- an absolute pathname to the file, or a relative filename
375 -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
376 -- searches the standard locations for the appropriate library.
377 --
378 -- Returns:
379 --
380 -- Nothing => success
381 -- Just err_msg => failure
382 loadDLL :: HscEnv -> String -> IO (Maybe String)
383 loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
384
385 loadArchive :: HscEnv -> String -> IO ()
386 loadArchive hsc_env str = iservCmd hsc_env (LoadArchive str)
387
388 loadObj :: HscEnv -> String -> IO ()
389 loadObj hsc_env str = iservCmd hsc_env (LoadObj str)
390
391 unloadObj :: HscEnv -> String -> IO ()
392 unloadObj hsc_env str = iservCmd hsc_env (UnloadObj str)
393
394 addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
395 addLibrarySearchPath hsc_env str =
396 fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
397
398 removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
399 removeLibrarySearchPath hsc_env p =
400 iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
401
402 resolveObjs :: HscEnv -> IO SuccessFlag
403 resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
404
405 findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
406 findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
407
408
409 -- -----------------------------------------------------------------------------
410 -- Raw calls and messages
411
412 -- | Send a 'Message' and receive the response from the iserv process
413 iservCall :: Binary a => IServ -> Message a -> IO a
414 iservCall iserv@IServ{..} msg =
415 remoteCall iservPipe msg
416 `catch` \(e :: SomeException) -> handleIServFailure iserv e
417
418 -- | Read a value from the iserv process
419 readIServ :: IServ -> Get a -> IO a
420 readIServ iserv@IServ{..} get =
421 readPipe iservPipe get
422 `catch` \(e :: SomeException) -> handleIServFailure iserv e
423
424 -- | Send a value to the iserv process
425 writeIServ :: IServ -> Put -> IO ()
426 writeIServ iserv@IServ{..} put =
427 writePipe iservPipe put
428 `catch` \(e :: SomeException) -> handleIServFailure iserv e
429
430 handleIServFailure :: IServ -> SomeException -> IO a
431 handleIServFailure IServ{..} e = do
432 ex <- getProcessExitCode iservProcess
433 case ex of
434 Just (ExitFailure n) ->
435 throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
436 _ -> do
437 terminateProcess iservProcess
438 _ <- waitForProcess iservProcess
439 throw e
440
441 -- -----------------------------------------------------------------------------
442 -- Starting and stopping the iserv process
443
444 startIServ :: DynFlags -> IO IServ
445 startIServ dflags = do
446 let flavour
447 | WayProf `elem` ways dflags = "-prof"
448 | WayDyn `elem` ways dflags = "-dyn"
449 | otherwise = ""
450 prog = pgm_i dflags ++ flavour
451 opts = getOpts dflags opt_i
452 debugTraceMsg dflags 3 $ text "Starting " <> text prog
453 let createProc = lookupHook createIservProcessHook
454 (\cp -> do { (_,_,_,ph) <- createProcess cp
455 ; return ph })
456 dflags
457 (ph, rh, wh) <- runWithPipes createProc prog opts
458 lo_ref <- newIORef Nothing
459 cache_ref <- newIORef emptyUFM
460 return $ IServ
461 { iservPipe = Pipe { pipeRead = rh
462 , pipeWrite = wh
463 , pipeLeftovers = lo_ref }
464 , iservProcess = ph
465 , iservLookupSymbolCache = cache_ref
466 , iservPendingFrees = []
467 }
468
469 stopIServ :: HscEnv -> IO ()
470 stopIServ HscEnv{..} =
471 gmask $ \_restore -> do
472 m <- takeMVar hsc_iserv
473 maybe (return ()) stop m
474 putMVar hsc_iserv Nothing
475 where
476 stop iserv = do
477 ex <- getProcessExitCode (iservProcess iserv)
478 if isJust ex
479 then return ()
480 else iservCall iserv Shutdown
481
482 runWithPipes :: (CreateProcess -> IO ProcessHandle)
483 -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
484 #ifdef mingw32_HOST_OS
485 foreign import ccall "io.h _close"
486 c__close :: CInt -> IO CInt
487
488 foreign import ccall unsafe "io.h _get_osfhandle"
489 _get_osfhandle :: CInt -> IO CInt
490
491 runWithPipes createProc prog opts = do
492 (rfd1, wfd1) <- createPipeFd -- we read on rfd1
493 (rfd2, wfd2) <- createPipeFd -- we write on wfd2
494 wh_client <- _get_osfhandle wfd1
495 rh_client <- _get_osfhandle rfd2
496 let args = show wh_client : show rh_client : opts
497 ph <- createProc (proc prog args)
498 rh <- mkHandle rfd1
499 wh <- mkHandle wfd2
500 return (ph, rh, wh)
501 where mkHandle :: CInt -> IO Handle
502 mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
503 #else
504 runWithPipes createProc prog opts = do
505 (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
506 (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
507 setFdOption rfd1 CloseOnExec True
508 setFdOption wfd2 CloseOnExec True
509 let args = show wfd1 : show rfd2 : opts
510 ph <- createProc (proc prog args)
511 closeFd wfd1
512 closeFd rfd2
513 rh <- fdToHandle rfd1
514 wh <- fdToHandle wfd2
515 return (ph, rh, wh)
516 #endif
517
518 -- -----------------------------------------------------------------------------
519 {- Note [External GHCi pointers]
520
521 We have the following ways to reference things in GHCi:
522
523 HValue
524 ------
525
526 HValue is a direct reference to an value in the local heap. Obviously
527 we cannot use this to refer to things in the external process.
528
529
530 RemoteRef
531 ---------
532
533 RemoteRef is a StablePtr to a heap-resident value. When
534 -fexternal-interpreter is used, this value resides in the external
535 process's heap. RemoteRefs are mostly used to send pointers in
536 messages between GHC and iserv.
537
538 A RemoteRef must be explicitly freed when no longer required, using
539 freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
540
541 To get from a RemoteRef to an HValue you can use 'wormholeRef', which
542 fails with an error message if -fexternal-interpreter is in use.
543
544 ForeignRef
545 ----------
546
547 A ForeignRef is a RemoteRef with a finalizer that will free the
548 'RemoteRef' when it is gargabe collected. We mostly use ForeignHValue
549 on the GHC side.
550
551 The finalizer adds the RemoteRef to the iservPendingFrees list in the
552 IServ record. The next call to iservCmd will free any RemoteRefs in
553 the list. It was done this way rather than calling iservCmd directly,
554 because I didn't want to have arbitrary threads calling iservCmd. In
555 principle it would probably be ok, but it seems less hairy this way.
556 -}
557
558 -- | Creates a 'ForeignRef' that will automatically release the
559 -- 'RemoteRef' when it is no longer referenced.
560 mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
561 mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
562 where
563 !external = gopt Opt_ExternalInterpreter hsc_dflags
564 hvref = toHValueRef rref
565
566 free :: IO ()
567 free
568 | not external = freeRemoteRef hvref
569 | otherwise =
570 modifyMVar_ hsc_iserv $ \mb_iserv ->
571 case mb_iserv of
572 Nothing -> return Nothing -- already shut down
573 Just iserv@IServ{..} ->
574 return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
575
576 freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
577 freeHValueRefs _ [] = return ()
578 freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
579
580 -- | Convert a 'ForeignRef' to the value it references directly. This
581 -- only works when the interpreter is running in the same process as
582 -- the compiler, so it fails when @-fexternal-interpreter@ is on.
583 wormhole :: DynFlags -> ForeignRef a -> IO a
584 wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
585
586 -- | Convert an 'RemoteRef' to the value it references directly. This
587 -- only works when the interpreter is running in the same process as
588 -- the compiler, so it fails when @-fexternal-interpreter@ is on.
589 wormholeRef :: DynFlags -> RemoteRef a -> IO a
590 wormholeRef dflags r
591 | gopt Opt_ExternalInterpreter dflags
592 = throwIO (InstallationError
593 "this operation requires -fno-external-interpreter")
594 | otherwise
595 = localRef r
596
597 -- -----------------------------------------------------------------------------
598 -- Misc utils
599
600 mkEvalOpts :: DynFlags -> Bool -> EvalOpts
601 mkEvalOpts dflags step =
602 EvalOpts
603 { useSandboxThread = gopt Opt_GhciSandbox dflags
604 , singleStep = step
605 , breakOnException = gopt Opt_BreakOnException dflags
606 , breakOnError = gopt Opt_BreakOnError dflags }
607
608 fromEvalResult :: EvalResult a -> IO a
609 fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
610 fromEvalResult (EvalSuccess a) = return a