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