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