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