never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TupleSections #-}
6
7 -- | Interacting with the iserv interpreter, whether it is running on an
8 -- external process or in the current process.
9 --
10 module GHC.Runtime.Interpreter
11 ( module GHC.Runtime.Interpreter.Types
12
13 -- * High-level interface to the interpreter
14 , BCOOpts (..)
15 , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
16 , resumeStmt
17 , abandonStmt
18 , evalIO
19 , evalString
20 , evalStringToIOString
21 , mallocData
22 , createBCOs
23 , addSptEntry
24 , mkCostCentres
25 , costCentreStackInfo
26 , newBreakArray
27 , storeBreakpoint
28 , breakpointStatus
29 , getBreakpointVar
30 , getClosure
31 , getModBreaks
32 , seqHValue
33 , interpreterDynamic
34 , interpreterProfiled
35
36 -- * The object-code linker
37 , initObjLinker
38 , lookupSymbol
39 , lookupClosure
40 , loadDLL
41 , loadArchive
42 , loadObj
43 , unloadObj
44 , addLibrarySearchPath
45 , removeLibrarySearchPath
46 , resolveObjs
47 , findSystemLibrary
48
49 -- * Lower-level API using messages
50 , interpCmd, Message(..), withIServ, withIServ_
51 , stopInterp
52 , iservCall, readIServ, writeIServ
53 , purgeLookupSymbolCache
54 , freeHValueRefs
55 , mkFinalizedHValue
56 , wormhole, wormholeRef
57 , fromEvalResult
58 ) where
59
60 import GHC.Prelude
61
62 import GHC.IO (catchException)
63
64 import GHC.Runtime.Interpreter.Types
65 import GHCi.Message
66 import GHCi.RemoteTypes
67 import GHCi.ResolvedBCO
68 import GHCi.BreakArray (BreakArray)
69 import GHC.Types.BreakInfo (BreakInfo(..))
70 import GHC.ByteCode.Types
71
72 import GHC.Linker.Types
73
74 import GHC.Data.Maybe
75 import GHC.Data.FastString
76
77 import GHC.Types.Unique
78 import GHC.Types.SrcLoc
79 import GHC.Types.Unique.FM
80 import GHC.Types.Basic
81
82 import GHC.Utils.Panic
83 import GHC.Utils.Exception as Ex
84 import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
85 import GHC.Utils.Fingerprint
86 import GHC.Utils.Misc
87
88 import GHC.Unit.Module
89 import GHC.Unit.Module.ModIface
90 import GHC.Unit.Home.ModInfo
91 import GHC.Unit.Env
92
93 #if defined(HAVE_INTERNAL_INTERPRETER)
94 import GHCi.Run
95 import GHC.Platform.Ways
96 #endif
97
98 import Control.Concurrent
99 import Control.Monad
100 import Control.Monad.IO.Class
101 import Control.Monad.Catch as MC (mask, onException)
102 import Data.Binary
103 import Data.Binary.Put
104 import Data.ByteString (ByteString)
105 import qualified Data.ByteString.Lazy as LB
106 import Data.Array ((!))
107 import Data.IORef
108 import Foreign hiding (void)
109 import qualified GHC.Exts.Heap as Heap
110 import GHC.Stack.CCS (CostCentre,CostCentreStack)
111 import System.Exit
112 import GHC.IO.Handle.Types (Handle)
113 #if defined(mingw32_HOST_OS)
114 import Foreign.C
115 import GHC.IO.Handle.FD (fdToHandle)
116 #else
117 import System.Posix as Posix
118 #endif
119 import System.Directory
120 import System.Process
121 import GHC.Conc (pseq, par)
122
123 {- Note [Remote GHCi]
124
125 When the flag -fexternal-interpreter is given to GHC, interpreted code
126 is run in a separate process called iserv, and we communicate with the
127 external process over a pipe using Binary-encoded messages.
128
129 Motivation
130 ~~~~~~~~~~
131
132 When the interpreted code is running in a separate process, it can
133 use a different "way", e.g. profiled or dynamic. This means
134
135 - compiling Template Haskell code with -prof does not require
136 building the code without -prof first
137
138 - when GHC itself is profiled, it can interpret unprofiled code,
139 and the same applies to dynamic linking.
140
141 - An unprofiled GHCi can load and run profiled code, which means it
142 can use the stack-trace functionality provided by profiling without
143 taking the performance hit on the compiler that profiling would
144 entail.
145
146 For other reasons see remote-GHCi on the wiki.
147
148 Implementation Overview
149 ~~~~~~~~~~~~~~~~~~~~~~~
150
151 The main pieces are:
152
153 - libraries/ghci, containing:
154 - types for talking about remote values (GHCi.RemoteTypes)
155 - the message protocol (GHCi.Message),
156 - implementation of the messages (GHCi.Run)
157 - implementation of Template Haskell (GHCi.TH)
158 - a few other things needed to run interpreted code
159
160 - top-level iserv directory, containing the codefor the external
161 server. This is a fairly simple wrapper, most of the functionality
162 is provided by modules in libraries/ghci.
163
164 - This module which provides the interface to the server used
165 by the rest of GHC.
166
167 GHC works with and without -fexternal-interpreter. With the flag, all
168 interpreted code is run by the iserv binary. Without the flag,
169 interpreted code is run in the same process as GHC.
170
171 Things that do not work with -fexternal-interpreter
172 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
173
174 dynCompileExpr cannot work, because we have no way to run code of an
175 unknown type in the remote process. This API fails with an error
176 message if it is used with -fexternal-interpreter.
177
178 Other Notes on Remote GHCi
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~
180 * This wiki page has an implementation overview:
181 https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter
182 * Note [External GHCi pointers] in "GHC.Runtime.Interpreter"
183 * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
184 -}
185
186
187 -- | Run a command in the interpreter's context. With
188 -- @-fexternal-interpreter@, the command is serialized and sent to an
189 -- external iserv process, and the response is deserialized (hence the
190 -- @Binary@ constraint). With @-fno-external-interpreter@ we execute
191 -- the command directly here.
192 interpCmd :: Binary a => Interp -> Message a -> IO a
193 interpCmd interp msg = case interpInstance interp of
194 #if defined(HAVE_INTERNAL_INTERPRETER)
195 InternalInterp -> run msg -- Just run it directly
196 #endif
197 ExternalInterp c i -> withIServ_ c i $ \iserv ->
198 uninterruptibleMask_ $ -- Note [uninterruptibleMask_]
199 iservCall iserv msg
200
201
202 -- Note [uninterruptibleMask_ and interpCmd]
203 --
204 -- If we receive an async exception, such as ^C, while communicating
205 -- with the iserv process then we will be out-of-sync and not be able
206 -- to recover. Thus we use uninterruptibleMask_ during
207 -- communication. A ^C will be delivered to the iserv process (because
208 -- signals get sent to the whole process group) which will interrupt
209 -- the running computation and return an EvalException result.
210
211 -- | Grab a lock on the 'IServ' and do something with it.
212 -- Overloaded because this is used from TcM as well as IO.
213 withIServ
214 :: (ExceptionMonad m)
215 => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a
216 withIServ conf (IServ mIServState) action =
217 MC.mask $ \restore -> do
218 state <- liftIO $ takeMVar mIServState
219
220 iserv <- case state of
221 -- start the external iserv process if we haven't done so yet
222 IServPending ->
223 liftIO (spawnIServ conf)
224 `MC.onException` (liftIO $ putMVar mIServState state)
225
226 IServRunning inst -> return inst
227
228
229 let iserv' = iserv{ iservPendingFrees = [] }
230
231 (iserv'',a) <- (do
232 -- free any ForeignHValues that have been garbage collected.
233 liftIO $ when (not (null (iservPendingFrees iserv))) $
234 iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
235 -- run the inner action
236 restore $ action iserv')
237 `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv'))
238 liftIO $ putMVar mIServState (IServRunning iserv'')
239 return a
240
241 withIServ_
242 :: (MonadIO m, ExceptionMonad m)
243 => IServConfig -> IServ -> (IServInstance -> m a) -> m a
244 withIServ_ conf iserv action = withIServ conf iserv $ \inst ->
245 (inst,) <$> action inst
246
247 -- -----------------------------------------------------------------------------
248 -- Wrappers around messages
249
250 -- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
251 -- each of the results.
252 evalStmt
253 :: Interp
254 -> EvalOpts
255 -> EvalExpr ForeignHValue
256 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
257 evalStmt interp opts foreign_expr = do
258 status <- withExpr foreign_expr $ \expr ->
259 interpCmd interp (EvalStmt opts expr)
260 handleEvalStatus interp status
261 where
262 withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
263 withExpr (EvalThis fhv) cont =
264 withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
265 withExpr (EvalApp fl fr) cont =
266 withExpr fl $ \fl' ->
267 withExpr fr $ \fr' ->
268 cont (EvalApp fl' fr')
269
270 resumeStmt
271 :: Interp
272 -> EvalOpts
273 -> ForeignRef (ResumeContext [HValueRef])
274 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
275 resumeStmt interp opts resume_ctxt = do
276 status <- withForeignRef resume_ctxt $ \rhv ->
277 interpCmd interp (ResumeStmt opts rhv)
278 handleEvalStatus interp status
279
280 abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
281 abandonStmt interp resume_ctxt =
282 withForeignRef resume_ctxt $ \rhv ->
283 interpCmd interp (AbandonStmt rhv)
284
285 handleEvalStatus
286 :: Interp
287 -> EvalStatus [HValueRef]
288 -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
289 handleEvalStatus interp status =
290 case status of
291 EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
292 EvalComplete alloc res ->
293 EvalComplete alloc <$> addFinalizer res
294 where
295 addFinalizer (EvalException e) = return (EvalException e)
296 addFinalizer (EvalSuccess rs) =
297 EvalSuccess <$> mapM (mkFinalizedHValue interp) rs
298
299 -- | Execute an action of type @IO ()@
300 evalIO :: Interp -> ForeignHValue -> IO ()
301 evalIO interp fhv =
302 liftIO $ withForeignRef fhv $ \fhv ->
303 interpCmd interp (EvalIO fhv) >>= fromEvalResult
304
305 -- | Execute an action of type @IO String@
306 evalString :: Interp -> ForeignHValue -> IO String
307 evalString interp fhv =
308 liftIO $ withForeignRef fhv $ \fhv ->
309 interpCmd interp (EvalString fhv) >>= fromEvalResult
310
311 -- | Execute an action of type @String -> IO String@
312 evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String
313 evalStringToIOString interp fhv str =
314 liftIO $ withForeignRef fhv $ \fhv ->
315 interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult
316
317
318 -- | Allocate and store the given bytes in memory, returning a pointer
319 -- to the memory in the remote process.
320 mallocData :: Interp -> ByteString -> IO (RemotePtr ())
321 mallocData interp bs = interpCmd interp (MallocData bs)
322
323 mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
324 mkCostCentres interp mod ccs =
325 interpCmd interp (MkCostCentres mod ccs)
326
327 newtype BCOOpts = BCOOpts
328 { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization
329 }
330
331 -- | Create a set of BCOs that may be mutually recursive.
332 createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef]
333 createBCOs interp opts rbcos = do
334 let n_jobs = bco_n_jobs opts
335 -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel
336 if (n_jobs == 1)
337 then
338 interpCmd interp (CreateBCOs [runPut (put rbcos)])
339 else do
340 old_caps <- getNumCapabilities
341 if old_caps == n_jobs
342 then void $ evaluate puts
343 else bracket_ (setNumCapabilities n_jobs)
344 (setNumCapabilities old_caps)
345 (void $ evaluate puts)
346 interpCmd interp (CreateBCOs puts)
347 where
348 puts = parMap doChunk (chunkList 100 rbcos)
349
350 -- make sure we force the whole lazy ByteString
351 doChunk c = pseq (LB.length bs) bs
352 where bs = runPut (put c)
353
354 -- We don't have the parallel package, so roll our own simple parMap
355 parMap _ [] = []
356 parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
357 where fx = f x; fxs = parMap f xs
358
359 addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()
360 addSptEntry interp fpr ref =
361 withForeignRef ref $ \val ->
362 interpCmd interp (AddSptEntry fpr val)
363
364 costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]
365 costCentreStackInfo interp ccs =
366 interpCmd interp (CostCentreStackInfo ccs)
367
368 newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
369 newBreakArray interp size = do
370 breakArray <- interpCmd interp (NewBreakArray size)
371 mkFinalizedHValue interp breakArray
372
373 storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
374 storeBreakpoint interp ref ix cnt = do -- #19157
375 withForeignRef ref $ \breakarray ->
376 interpCmd interp (SetupBreakpoint breakarray ix cnt)
377
378 breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool
379 breakpointStatus interp ref ix =
380 withForeignRef ref $ \breakarray ->
381 interpCmd interp (BreakpointStatus breakarray ix)
382
383 getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
384 getBreakpointVar interp ref ix =
385 withForeignRef ref $ \apStack -> do
386 mb <- interpCmd interp (GetBreakpointVar apStack ix)
387 mapM (mkFinalizedHValue interp) mb
388
389 getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
390 getClosure interp ref =
391 withForeignRef ref $ \hval -> do
392 mb <- interpCmd interp (GetClosure hval)
393 mapM (mkFinalizedHValue interp) mb
394
395 -- | Send a Seq message to the iserv process to force a value #2950
396 seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
397 seqHValue interp unit_env ref =
398 withForeignRef ref $ \hval -> do
399 status <- interpCmd interp (Seq hval)
400 handleSeqHValueStatus interp unit_env status
401
402 -- | Process the result of a Seq or ResumeSeq message. #2950
403 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
404 handleSeqHValueStatus interp unit_env eval_status =
405 case eval_status of
406 (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do
407 -- A breakpoint was hit; inform the user and tell them
408 -- which breakpoint was hit.
409 resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
410 let hmi = expectJust "handleRunStatus" $
411 lookupHptDirectly (ue_hpt unit_env)
412 (mkUniqueGrimily mod_uniq)
413 modl = mi_module (hm_iface hmi)
414 bp | is_exception = Nothing
415 | otherwise = Just (BreakInfo modl ix)
416 sdocBpLoc = brackets . ppr . getSeqBpSpan
417 putStrLn ("*** Ignoring breakpoint " ++
418 (showSDocUnsafe $ sdocBpLoc bp))
419 -- resume the seq (:force) processing in the iserv process
420 withForeignRef resume_ctxt_fhv $ \hval -> do
421 status <- interpCmd interp (ResumeSeq hval)
422 handleSeqHValueStatus interp unit_env status
423 (EvalComplete _ r) -> return r
424 where
425 getSeqBpSpan :: Maybe BreakInfo -> SrcSpan
426 -- Just case: Stopped at a breakpoint, extract SrcSpan information
427 -- from the breakpoint.
428 getSeqBpSpan (Just BreakInfo{..}) =
429 (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number
430 -- Nothing case - should not occur!
431 -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq
432 getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")
433 breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $
434 lookupHpt (ue_hpt unit_env) (moduleName mod)
435
436
437 -- -----------------------------------------------------------------------------
438 -- Interface to the object-code linker
439
440 initObjLinker :: Interp -> IO ()
441 initObjLinker interp = interpCmd interp InitLinker
442
443 lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
444 lookupSymbol interp str = case interpInstance interp of
445 #if defined(HAVE_INTERNAL_INTERPRETER)
446 InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
447 #endif
448
449 ExternalInterp c i -> withIServ c i $ \iserv -> do
450 -- Profiling of GHCi showed a lot of time and allocation spent
451 -- making cross-process LookupSymbol calls, so I added a GHC-side
452 -- cache which sped things up quite a lot. We have to be careful
453 -- to purge this cache when unloading code though.
454 let cache = iservLookupSymbolCache iserv
455 case lookupUFM cache str of
456 Just p -> return (iserv, Just p)
457 Nothing -> do
458 m <- uninterruptibleMask_ $
459 iservCall iserv (LookupSymbol (unpackFS str))
460 case m of
461 Nothing -> return (iserv, Nothing)
462 Just r -> do
463 let p = fromRemotePtr r
464 cache' = addToUFM cache str p
465 iserv' = iserv {iservLookupSymbolCache = cache'}
466 return (iserv', Just p)
467
468 lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
469 lookupClosure interp str =
470 interpCmd interp (LookupClosure str)
471
472 purgeLookupSymbolCache :: Interp -> IO ()
473 purgeLookupSymbolCache interp = case interpInstance interp of
474 #if defined(HAVE_INTERNAL_INTERPRETER)
475 InternalInterp -> pure ()
476 #endif
477 ExternalInterp _ (IServ mstate) ->
478 modifyMVar_ mstate $ \state -> pure $ case state of
479 IServPending -> state
480 IServRunning iserv -> IServRunning
481 (iserv { iservLookupSymbolCache = emptyUFM })
482
483
484 -- | loadDLL loads a dynamic library using the OS's native linker
485 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
486 -- an absolute pathname to the file, or a relative filename
487 -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
488 -- searches the standard locations for the appropriate library.
489 --
490 -- Returns:
491 --
492 -- Nothing => success
493 -- Just err_msg => failure
494 loadDLL :: Interp -> String -> IO (Maybe String)
495 loadDLL interp str = interpCmd interp (LoadDLL str)
496
497 loadArchive :: Interp -> String -> IO ()
498 loadArchive interp path = do
499 path' <- canonicalizePath path -- Note [loadObj and relative paths]
500 interpCmd interp (LoadArchive path')
501
502 loadObj :: Interp -> String -> IO ()
503 loadObj interp path = do
504 path' <- canonicalizePath path -- Note [loadObj and relative paths]
505 interpCmd interp (LoadObj path')
506
507 unloadObj :: Interp -> String -> IO ()
508 unloadObj interp path = do
509 path' <- canonicalizePath path -- Note [loadObj and relative paths]
510 interpCmd interp (UnloadObj path')
511
512 -- Note [loadObj and relative paths]
513 -- the iserv process might have a different current directory from the
514 -- GHC process, so we must make paths absolute before sending them
515 -- over.
516
517 addLibrarySearchPath :: Interp -> String -> IO (Ptr ())
518 addLibrarySearchPath interp str =
519 fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str)
520
521 removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool
522 removeLibrarySearchPath interp p =
523 interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p))
524
525 resolveObjs :: Interp -> IO SuccessFlag
526 resolveObjs interp = successIf <$> interpCmd interp ResolveObjs
527
528 findSystemLibrary :: Interp -> String -> IO (Maybe String)
529 findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)
530
531
532 -- -----------------------------------------------------------------------------
533 -- Raw calls and messages
534
535 -- | Send a 'Message' and receive the response from the iserv process
536 iservCall :: Binary a => IServInstance -> Message a -> IO a
537 iservCall iserv msg =
538 remoteCall (iservPipe iserv) msg
539 `catchException` \(e :: SomeException) -> handleIServFailure iserv e
540
541 -- | Read a value from the iserv process
542 readIServ :: IServInstance -> Get a -> IO a
543 readIServ iserv get =
544 readPipe (iservPipe iserv) get
545 `catchException` \(e :: SomeException) -> handleIServFailure iserv e
546
547 -- | Send a value to the iserv process
548 writeIServ :: IServInstance -> Put -> IO ()
549 writeIServ iserv put =
550 writePipe (iservPipe iserv) put
551 `catchException` \(e :: SomeException) -> handleIServFailure iserv e
552
553 handleIServFailure :: IServInstance -> SomeException -> IO a
554 handleIServFailure iserv e = do
555 let proc = iservProcess iserv
556 ex <- getProcessExitCode proc
557 case ex of
558 Just (ExitFailure n) ->
559 throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
560 _ -> do
561 terminateProcess proc
562 _ <- waitForProcess proc
563 throw e
564
565 -- | Spawn an external interpreter
566 spawnIServ :: IServConfig -> IO IServInstance
567 spawnIServ conf = do
568 iservConfTrace conf
569 let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp
570 ; return ph })
571 (iservConfHook conf)
572 (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)
573 (iservConfOpts conf)
574 lo_ref <- newIORef Nothing
575 return $ IServInstance
576 { iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }
577 , iservProcess = ph
578 , iservLookupSymbolCache = emptyUFM
579 , iservPendingFrees = []
580 }
581
582 -- | Stop the interpreter
583 stopInterp :: Interp -> IO ()
584 stopInterp interp = case interpInstance interp of
585 #if defined(HAVE_INTERNAL_INTERPRETER)
586 InternalInterp -> pure ()
587 #endif
588 ExternalInterp _ (IServ mstate) ->
589 MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
590 case state of
591 IServPending -> pure state -- already stopped
592 IServRunning i -> do
593 ex <- getProcessExitCode (iservProcess i)
594 if isJust ex
595 then pure ()
596 else iservCall i Shutdown
597 pure IServPending
598
599 runWithPipes :: (CreateProcess -> IO ProcessHandle)
600 -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
601 #if defined(mingw32_HOST_OS)
602 foreign import ccall "io.h _close"
603 c__close :: CInt -> IO CInt
604
605 foreign import ccall unsafe "io.h _get_osfhandle"
606 _get_osfhandle :: CInt -> IO CInt
607
608 runWithPipes createProc prog opts = do
609 (rfd1, wfd1) <- createPipeFd -- we read on rfd1
610 (rfd2, wfd2) <- createPipeFd -- we write on wfd2
611 wh_client <- _get_osfhandle wfd1
612 rh_client <- _get_osfhandle rfd2
613 let args = show wh_client : show rh_client : opts
614 ph <- createProc (proc prog args)
615 rh <- mkHandle rfd1
616 wh <- mkHandle wfd2
617 return (ph, rh, wh)
618 where mkHandle :: CInt -> IO Handle
619 mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)
620
621 #else
622 runWithPipes createProc prog opts = do
623 (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
624 (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
625 setFdOption rfd1 CloseOnExec True
626 setFdOption wfd2 CloseOnExec True
627 let args = show wfd1 : show rfd2 : opts
628 ph <- createProc (proc prog args)
629 closeFd wfd1
630 closeFd rfd2
631 rh <- fdToHandle rfd1
632 wh <- fdToHandle wfd2
633 return (ph, rh, wh)
634 #endif
635
636 -- -----------------------------------------------------------------------------
637 {- Note [External GHCi pointers]
638
639 We have the following ways to reference things in GHCi:
640
641 HValue
642 ------
643
644 HValue is a direct reference to a value in the local heap. Obviously
645 we cannot use this to refer to things in the external process.
646
647
648 RemoteRef
649 ---------
650
651 RemoteRef is a StablePtr to a heap-resident value. When
652 -fexternal-interpreter is used, this value resides in the external
653 process's heap. RemoteRefs are mostly used to send pointers in
654 messages between GHC and iserv.
655
656 A RemoteRef must be explicitly freed when no longer required, using
657 freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
658
659 To get from a RemoteRef to an HValue you can use 'wormholeRef', which
660 fails with an error message if -fexternal-interpreter is in use.
661
662 ForeignRef
663 ----------
664
665 A ForeignRef is a RemoteRef with a finalizer that will free the
666 'RemoteRef' when it is garbage collected. We mostly use ForeignHValue
667 on the GHC side.
668
669 The finalizer adds the RemoteRef to the iservPendingFrees list in the
670 IServ record. The next call to interpCmd will free any RemoteRefs in
671 the list. It was done this way rather than calling interpCmd directly,
672 because I didn't want to have arbitrary threads calling interpCmd. In
673 principle it would probably be ok, but it seems less hairy this way.
674 -}
675
676 -- | Creates a 'ForeignRef' that will automatically release the
677 -- 'RemoteRef' when it is no longer referenced.
678 mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)
679 mkFinalizedHValue interp rref = do
680 let hvref = toHValueRef rref
681
682 free <- case interpInstance interp of
683 #if defined(HAVE_INTERNAL_INTERPRETER)
684 InternalInterp -> return (freeRemoteRef hvref)
685 #endif
686 ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->
687 case state of
688 IServPending {} -> pure state -- already shut down
689 IServRunning inst -> do
690 let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst}
691 pure (IServRunning inst')
692
693 mkForeignRef rref free
694
695
696 freeHValueRefs :: Interp -> [HValueRef] -> IO ()
697 freeHValueRefs _ [] = return ()
698 freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)
699
700 -- | Convert a 'ForeignRef' to the value it references directly. This
701 -- only works when the interpreter is running in the same process as
702 -- the compiler, so it fails when @-fexternal-interpreter@ is on.
703 wormhole :: Interp -> ForeignRef a -> IO a
704 wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)
705
706 -- | Convert an 'RemoteRef' to the value it references directly. This
707 -- only works when the interpreter is running in the same process as
708 -- the compiler, so it fails when @-fexternal-interpreter@ is on.
709 wormholeRef :: Interp -> RemoteRef a -> IO a
710 wormholeRef interp _r = case interpInstance interp of
711 #if defined(HAVE_INTERNAL_INTERPRETER)
712 InternalInterp -> localRef _r
713 #endif
714 ExternalInterp {}
715 -> throwIO (InstallationError "this operation requires -fno-external-interpreter")
716
717 -- -----------------------------------------------------------------------------
718 -- Misc utils
719
720 fromEvalResult :: EvalResult a -> IO a
721 fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
722 fromEvalResult (EvalSuccess a) = return a
723
724 getModBreaks :: HomeModInfo -> ModBreaks
725 getModBreaks hmi
726 | Just linkable <- hm_linkable hmi,
727 [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable
728 = fromMaybe emptyModBreaks (bc_breaks cbc)
729 | otherwise
730 = emptyModBreaks -- probably object code
731 where
732 -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
733 onlyBCOs :: Unlinked -> Maybe CompiledByteCode
734 onlyBCOs (BCOs cbc _) = Just cbc
735 onlyBCOs _ = Nothing
736
737 -- | Interpreter uses Profiling way
738 interpreterProfiled :: Interp -> Bool
739 interpreterProfiled interp = case interpInstance interp of
740 #if defined(HAVE_INTERNAL_INTERPRETER)
741 InternalInterp -> hostIsProfiled
742 #endif
743 ExternalInterp c _ -> iservConfProfiled c
744
745 -- | Interpreter uses Dynamic way
746 interpreterDynamic :: Interp -> Bool
747 interpreterDynamic interp = case interpInstance interp of
748 #if defined(HAVE_INTERNAL_INTERPRETER)
749 InternalInterp -> hostIsDynamic
750 #endif
751 ExternalInterp c _ -> iservConfDynamic c