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