Simplify Foreign.Marshal.Alloc functions with ScopedTypeVariables
[ghc.git] / libraries / ghci / GHCi / Message.hs
1 {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
2 GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards,
3 CPP #-}
4 {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
5
6 -- |
7 -- Remote GHCi message types and serialization.
8 --
9 -- For details on Remote GHCi, see Note [Remote GHCi] in
10 -- compiler/ghci/GHCi.hs.
11 --
12 module GHCi.Message
13 ( Message(..), Msg(..)
14 , THMessage(..), THMsg(..)
15 , QResult(..)
16 , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
17 , SerializableException(..)
18 , toSerializableException, fromSerializableException
19 , THResult(..), THResultType(..)
20 , ResumeContext(..)
21 , QState(..)
22 , getMessage, putMessage, getTHMessage, putTHMessage
23 , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe
24 ) where
25
26 import GHCi.RemoteTypes
27 import GHCi.InfoTable (StgInfoTable)
28 import GHCi.FFI
29 import GHCi.TH.Binary ()
30 import GHCi.BreakArray
31
32 import GHC.LanguageExtensions
33 import GHC.ForeignSrcLang
34 import GHC.Fingerprint
35 import Control.Concurrent
36 import Control.Exception
37 import Data.Binary
38 import Data.Binary.Get
39 import Data.Binary.Put
40 import Data.ByteString (ByteString)
41 import qualified Data.ByteString as B
42 import qualified Data.ByteString.Lazy as LB
43 import Data.Dynamic
44 #if MIN_VERSION_base(4,10,0)
45 -- Previously this was re-exported by Data.Dynamic
46 import Data.Typeable (TypeRep)
47 #endif
48 import Data.IORef
49 import Data.Map (Map)
50 import GHC.Generics
51 import GHC.Stack.CCS
52 import qualified Language.Haskell.TH as TH
53 import qualified Language.Haskell.TH.Syntax as TH
54 import System.Exit
55 import System.IO
56 import System.IO.Error
57
58 -- -----------------------------------------------------------------------------
59 -- The RPC protocol between GHC and the interactive server
60
61 -- | A @Message a@ is a message that returns a value of type @a@.
62 -- These are requests sent from GHC to the server.
63 data Message a where
64 -- | Exit the iserv process
65 Shutdown :: Message ()
66
67 -- RTS Linker -------------------------------------------
68
69 -- These all invoke the corresponding functions in the RTS Linker API.
70 InitLinker :: Message ()
71 LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
72 LookupClosure :: String -> Message (Maybe HValueRef)
73 LoadDLL :: String -> Message (Maybe String)
74 LoadArchive :: String -> Message () -- error?
75 LoadObj :: String -> Message () -- error?
76 UnloadObj :: String -> Message () -- error?
77 AddLibrarySearchPath :: String -> Message (RemotePtr ())
78 RemoveLibrarySearchPath :: RemotePtr () -> Message Bool
79 ResolveObjs :: Message Bool
80 FindSystemLibrary :: String -> Message (Maybe String)
81
82 -- Interpreter -------------------------------------------
83
84 -- | Create a set of BCO objects, and return HValueRefs to them
85 -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not
86 -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs
87 -- in parallel. See @createBCOs@ in compiler/ghci/GHCi.hsc.
88 CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
89
90 -- | Release 'HValueRef's
91 FreeHValueRefs :: [HValueRef] -> Message ()
92
93 -- | Add entries to the Static Pointer Table
94 AddSptEntry :: Fingerprint -> HValueRef -> Message ()
95
96 -- | Malloc some data and return a 'RemotePtr' to it
97 MallocData :: ByteString -> Message (RemotePtr ())
98 MallocStrings :: [ByteString] -> Message [RemotePtr ()]
99
100 -- | Calls 'GHCi.FFI.prepareForeignCall'
101 PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
102
103 -- | Free data previously created by 'PrepFFI'
104 FreeFFI :: RemotePtr C_ffi_cif -> Message ()
105
106 -- | Create an info table for a constructor
107 MkConInfoTable
108 :: Int -- ptr words
109 -> Int -- non-ptr words
110 -> Int -- constr tag
111 -> Int -- pointer tag
112 -> [Word8] -- constructor desccription
113 -> Message (RemotePtr StgInfoTable)
114
115 -- | Evaluate a statement
116 EvalStmt
117 :: EvalOpts
118 -> EvalExpr HValueRef {- IO [a] -}
119 -> Message (EvalStatus [HValueRef]) {- [a] -}
120
121 -- | Resume evaluation of a statement after a breakpoint
122 ResumeStmt
123 :: EvalOpts
124 -> RemoteRef (ResumeContext [HValueRef])
125 -> Message (EvalStatus [HValueRef])
126
127 -- | Abandon evaluation of a statement after a breakpoint
128 AbandonStmt
129 :: RemoteRef (ResumeContext [HValueRef])
130 -> Message ()
131
132 -- | Evaluate something of type @IO String@
133 EvalString
134 :: HValueRef {- IO String -}
135 -> Message (EvalResult String)
136
137 -- | Evaluate something of type @String -> IO String@
138 EvalStringToString
139 :: HValueRef {- String -> IO String -}
140 -> String
141 -> Message (EvalResult String)
142
143 -- | Evaluate something of type @IO ()@
144 EvalIO
145 :: HValueRef {- IO a -}
146 -> Message (EvalResult ())
147
148 -- | Create a set of CostCentres with the same module name
149 MkCostCentres
150 :: String -- module, RemotePtr so it can be shared
151 -> [(String,String)] -- (name, SrcSpan)
152 -> Message [RemotePtr CostCentre]
153
154 -- | Show a 'CostCentreStack' as a @[String]@
155 CostCentreStackInfo
156 :: RemotePtr CostCentreStack
157 -> Message [String]
158
159 -- | Create a new array of breakpoint flags
160 NewBreakArray
161 :: Int -- size
162 -> Message (RemoteRef BreakArray)
163
164 -- | Enable a breakpoint
165 EnableBreakpoint
166 :: RemoteRef BreakArray
167 -> Int -- index
168 -> Bool -- on or off
169 -> Message ()
170
171 -- | Query the status of a breakpoint (True <=> enabled)
172 BreakpointStatus
173 :: RemoteRef BreakArray
174 -> Int -- index
175 -> Message Bool -- True <=> enabled
176
177 -- | Get a reference to a free variable at a breakpoint
178 GetBreakpointVar
179 :: HValueRef -- the AP_STACK from EvalBreak
180 -> Int
181 -> Message (Maybe HValueRef)
182
183 -- Template Haskell -------------------------------------------
184 -- For more details on how TH works with Remote GHCi, see
185 -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
186
187 -- | Start a new TH module, return a state token that should be
188 StartTH :: Message (RemoteRef (IORef QState))
189
190 -- | Evaluate a TH computation.
191 --
192 -- Returns a ByteString, because we have to force the result
193 -- before returning it to ensure there are no errors lurking
194 -- in it. The TH types don't have NFData instances, and even if
195 -- they did, we have to serialize the value anyway, so we might
196 -- as well serialize it to force it.
197 RunTH
198 :: RemoteRef (IORef QState)
199 -> HValueRef {- e.g. TH.Q TH.Exp -}
200 -> THResultType
201 -> Maybe TH.Loc
202 -> Message (QResult ByteString)
203
204 -- | Run the given mod finalizers.
205 RunModFinalizers :: RemoteRef (IORef QState)
206 -> [RemoteRef (TH.Q ())]
207 -> Message (QResult ())
208
209 deriving instance Show (Message a)
210
211
212 -- | Template Haskell return values
213 data QResult a
214 = QDone a
215 -- ^ RunTH finished successfully; return value follows
216 | QException String
217 -- ^ RunTH threw an exception
218 | QFail String
219 -- ^ RunTH called 'fail'
220 deriving (Generic, Show)
221
222 instance Binary a => Binary (QResult a)
223
224
225 -- | Messages sent back to GHC from GHCi.TH, to implement the methods
226 -- of 'Quasi'. For an overview of how TH works with Remote GHCi, see
227 -- Note [Remote Template Haskell] in GHCi.TH.
228 data THMessage a where
229 NewName :: String -> THMessage (THResult TH.Name)
230 Report :: Bool -> String -> THMessage (THResult ())
231 LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name))
232 Reify :: TH.Name -> THMessage (THResult TH.Info)
233 ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity))
234 ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
235 ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
236 ReifyAnnotations :: TH.AnnLookup -> TypeRep
237 -> THMessage (THResult [ByteString])
238 ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)
239 ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
240
241 AddDependentFile :: FilePath -> THMessage (THResult ())
242 AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
243 AddCorePlugin :: String -> THMessage (THResult ())
244 AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
245 AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
246 IsExtEnabled :: Extension -> THMessage (THResult Bool)
247 ExtsEnabled :: THMessage (THResult [Extension])
248
249 StartRecover :: THMessage ()
250 EndRecover :: Bool -> THMessage ()
251
252 -- | Indicates that this RunTH is finished, and the next message
253 -- will be the result of RunTH (a QResult).
254 RunTHDone :: THMessage ()
255
256 deriving instance Show (THMessage a)
257
258 data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a)
259
260 getTHMessage :: Get THMsg
261 getTHMessage = do
262 b <- getWord8
263 case b of
264 0 -> THMsg <$> NewName <$> get
265 1 -> THMsg <$> (Report <$> get <*> get)
266 2 -> THMsg <$> (LookupName <$> get <*> get)
267 3 -> THMsg <$> Reify <$> get
268 4 -> THMsg <$> ReifyFixity <$> get
269 5 -> THMsg <$> (ReifyInstances <$> get <*> get)
270 6 -> THMsg <$> ReifyRoles <$> get
271 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get)
272 8 -> THMsg <$> ReifyModule <$> get
273 9 -> THMsg <$> ReifyConStrictness <$> get
274 10 -> THMsg <$> AddDependentFile <$> get
275 11 -> THMsg <$> AddTopDecls <$> get
276 12 -> THMsg <$> (IsExtEnabled <$> get)
277 13 -> THMsg <$> return ExtsEnabled
278 14 -> THMsg <$> return StartRecover
279 15 -> THMsg <$> EndRecover <$> get
280 16 -> return (THMsg RunTHDone)
281 17 -> THMsg <$> AddModFinalizer <$> get
282 18 -> THMsg <$> (AddForeignFile <$> get <*> get)
283 _ -> THMsg <$> AddCorePlugin <$> get
284
285 putTHMessage :: THMessage a -> Put
286 putTHMessage m = case m of
287 NewName a -> putWord8 0 >> put a
288 Report a b -> putWord8 1 >> put a >> put b
289 LookupName a b -> putWord8 2 >> put a >> put b
290 Reify a -> putWord8 3 >> put a
291 ReifyFixity a -> putWord8 4 >> put a
292 ReifyInstances a b -> putWord8 5 >> put a >> put b
293 ReifyRoles a -> putWord8 6 >> put a
294 ReifyAnnotations a b -> putWord8 7 >> put a >> put b
295 ReifyModule a -> putWord8 8 >> put a
296 ReifyConStrictness a -> putWord8 9 >> put a
297 AddDependentFile a -> putWord8 10 >> put a
298 AddTopDecls a -> putWord8 11 >> put a
299 IsExtEnabled a -> putWord8 12 >> put a
300 ExtsEnabled -> putWord8 13
301 StartRecover -> putWord8 14
302 EndRecover a -> putWord8 15 >> put a
303 RunTHDone -> putWord8 16
304 AddModFinalizer a -> putWord8 17 >> put a
305 AddForeignFile lang a -> putWord8 18 >> put lang >> put a
306 AddCorePlugin a -> putWord8 19 >> put a
307
308
309 data EvalOpts = EvalOpts
310 { useSandboxThread :: Bool
311 , singleStep :: Bool
312 , breakOnException :: Bool
313 , breakOnError :: Bool
314 }
315 deriving (Generic, Show)
316
317 instance Binary EvalOpts
318
319 data ResumeContext a = ResumeContext
320 { resumeBreakMVar :: MVar ()
321 , resumeStatusMVar :: MVar (EvalStatus a)
322 , resumeThreadId :: ThreadId
323 }
324
325 -- | We can pass simple expressions to EvalStmt, consisting of values
326 -- and application. This allows us to wrap the statement to be
327 -- executed in another function, which is used by GHCi to implement
328 -- :set args and :set prog. It might be worthwhile to extend this
329 -- little language in the future.
330 data EvalExpr a
331 = EvalThis a
332 | EvalApp (EvalExpr a) (EvalExpr a)
333 deriving (Generic, Show)
334
335 instance Binary a => Binary (EvalExpr a)
336
337 type EvalStatus a = EvalStatus_ a a
338
339 data EvalStatus_ a b
340 = EvalComplete Word64 (EvalResult a)
341 | EvalBreak Bool
342 HValueRef{- AP_STACK -}
343 Int {- break index -}
344 Int {- uniq of ModuleName -}
345 (RemoteRef (ResumeContext b))
346 (RemotePtr CostCentreStack) -- Cost centre stack
347 deriving (Generic, Show)
348
349 instance Binary a => Binary (EvalStatus_ a b)
350
351 data EvalResult a
352 = EvalException SerializableException
353 | EvalSuccess a
354 deriving (Generic, Show)
355
356 instance Binary a => Binary (EvalResult a)
357
358 -- SomeException can't be serialized because it contains dynamic
359 -- types. However, we do very limited things with the exceptions that
360 -- are thrown by interpreted computations:
361 --
362 -- * We print them, e.g. "*** Exception: <something>"
363 -- * UserInterrupt has a special meaning
364 -- * In ghc -e, exitWith should exit with the appropriate exit code
365 --
366 -- So all we need to do is distinguish UserInterrupt and ExitCode, and
367 -- all other exceptions can be represented by their 'show' string.
368 --
369 data SerializableException
370 = EUserInterrupt
371 | EExitCode ExitCode
372 | EOtherException String
373 deriving (Generic, Show)
374
375 toSerializableException :: SomeException -> SerializableException
376 toSerializableException ex
377 | Just UserInterrupt <- fromException ex = EUserInterrupt
378 | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
379 | otherwise = EOtherException (show (ex :: SomeException))
380
381 fromSerializableException :: SerializableException -> SomeException
382 fromSerializableException EUserInterrupt = toException UserInterrupt
383 fromSerializableException (EExitCode c) = toException c
384 fromSerializableException (EOtherException str) = toException (ErrorCall str)
385
386 instance Binary ExitCode
387 instance Binary SerializableException
388
389 data THResult a
390 = THException String
391 | THComplete a
392 deriving (Generic, Show)
393
394 instance Binary a => Binary (THResult a)
395
396 data THResultType = THExp | THPat | THType | THDec | THAnnWrapper
397 deriving (Enum, Show, Generic)
398
399 instance Binary THResultType
400
401 -- | The server-side Template Haskell state. This is created by the
402 -- StartTH message. A new one is created per module that GHC
403 -- typechecks.
404 data QState = QState
405 { qsMap :: Map TypeRep Dynamic
406 -- ^ persistent data between splices in a module
407 , qsLocation :: Maybe TH.Loc
408 -- ^ location for current splice, if any
409 , qsPipe :: Pipe
410 -- ^ pipe to communicate with GHC
411 }
412 instance Show QState where show _ = "<QState>"
413
414 data Msg = forall a . (Binary a, Show a) => Msg (Message a)
415
416 getMessage :: Get Msg
417 getMessage = do
418 b <- getWord8
419 case b of
420 0 -> Msg <$> return Shutdown
421 1 -> Msg <$> return InitLinker
422 2 -> Msg <$> LookupSymbol <$> get
423 3 -> Msg <$> LookupClosure <$> get
424 4 -> Msg <$> LoadDLL <$> get
425 5 -> Msg <$> LoadArchive <$> get
426 6 -> Msg <$> LoadObj <$> get
427 7 -> Msg <$> UnloadObj <$> get
428 8 -> Msg <$> AddLibrarySearchPath <$> get
429 9 -> Msg <$> RemoveLibrarySearchPath <$> get
430 10 -> Msg <$> return ResolveObjs
431 11 -> Msg <$> FindSystemLibrary <$> get
432 12 -> Msg <$> CreateBCOs <$> get
433 13 -> Msg <$> FreeHValueRefs <$> get
434 14 -> Msg <$> MallocData <$> get
435 15 -> Msg <$> MallocStrings <$> get
436 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
437 17 -> Msg <$> FreeFFI <$> get
438 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)
439 19 -> Msg <$> (EvalStmt <$> get <*> get)
440 20 -> Msg <$> (ResumeStmt <$> get <*> get)
441 21 -> Msg <$> (AbandonStmt <$> get)
442 22 -> Msg <$> (EvalString <$> get)
443 23 -> Msg <$> (EvalStringToString <$> get <*> get)
444 24 -> Msg <$> (EvalIO <$> get)
445 25 -> Msg <$> (MkCostCentres <$> get <*> get)
446 26 -> Msg <$> (CostCentreStackInfo <$> get)
447 27 -> Msg <$> (NewBreakArray <$> get)
448 28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
449 29 -> Msg <$> (BreakpointStatus <$> get <*> get)
450 30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
451 31 -> Msg <$> return StartTH
452 32 -> Msg <$> (RunModFinalizers <$> get <*> get)
453 33 -> Msg <$> (AddSptEntry <$> get <*> get)
454 _ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
455
456 putMessage :: Message a -> Put
457 putMessage m = case m of
458 Shutdown -> putWord8 0
459 InitLinker -> putWord8 1
460 LookupSymbol str -> putWord8 2 >> put str
461 LookupClosure str -> putWord8 3 >> put str
462 LoadDLL str -> putWord8 4 >> put str
463 LoadArchive str -> putWord8 5 >> put str
464 LoadObj str -> putWord8 6 >> put str
465 UnloadObj str -> putWord8 7 >> put str
466 AddLibrarySearchPath str -> putWord8 8 >> put str
467 RemoveLibrarySearchPath ptr -> putWord8 9 >> put ptr
468 ResolveObjs -> putWord8 10
469 FindSystemLibrary str -> putWord8 11 >> put str
470 CreateBCOs bco -> putWord8 12 >> put bco
471 FreeHValueRefs val -> putWord8 13 >> put val
472 MallocData bs -> putWord8 14 >> put bs
473 MallocStrings bss -> putWord8 15 >> put bss
474 PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
475 FreeFFI p -> putWord8 17 >> put p
476 MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d
477 EvalStmt opts val -> putWord8 19 >> put opts >> put val
478 ResumeStmt opts val -> putWord8 20 >> put opts >> put val
479 AbandonStmt val -> putWord8 21 >> put val
480 EvalString val -> putWord8 22 >> put val
481 EvalStringToString str val -> putWord8 23 >> put str >> put val
482 EvalIO val -> putWord8 24 >> put val
483 MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs
484 CostCentreStackInfo ptr -> putWord8 26 >> put ptr
485 NewBreakArray sz -> putWord8 27 >> put sz
486 EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b
487 BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix
488 GetBreakpointVar a b -> putWord8 30 >> put a >> put b
489 StartTH -> putWord8 31
490 RunModFinalizers a b -> putWord8 32 >> put a >> put b
491 AddSptEntry a b -> putWord8 33 >> put a >> put b
492 RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty
493
494 -- -----------------------------------------------------------------------------
495 -- Reading/writing messages
496
497 data Pipe = Pipe
498 { pipeRead :: Handle
499 , pipeWrite :: Handle
500 , pipeLeftovers :: IORef (Maybe ByteString)
501 }
502
503 remoteCall :: Binary a => Pipe -> Message a -> IO a
504 remoteCall pipe msg = do
505 writePipe pipe (putMessage msg)
506 readPipe pipe get
507
508 remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a
509 remoteTHCall pipe msg = do
510 writePipe pipe (putTHMessage msg)
511 readPipe pipe get
512
513 writePipe :: Pipe -> Put -> IO ()
514 writePipe Pipe{..} put
515 | LB.null bs = return ()
516 | otherwise = do
517 LB.hPut pipeWrite bs
518 hFlush pipeWrite
519 where
520 bs = runPut put
521
522 readPipe :: Pipe -> Get a -> IO a
523 readPipe Pipe{..} get = do
524 leftovers <- readIORef pipeLeftovers
525 m <- getBin pipeRead get leftovers
526 case m of
527 Nothing -> throw $
528 mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing
529 Just (result, new_leftovers) -> do
530 writeIORef pipeLeftovers new_leftovers
531 return result
532
533 getBin
534 :: Handle -> Get a -> Maybe ByteString
535 -> IO (Maybe (a, Maybe ByteString))
536
537 getBin h get leftover = go leftover (runGetIncremental get)
538 where
539 go Nothing (Done leftover _ msg) =
540 return (Just (msg, if B.null leftover then Nothing else Just leftover))
541 go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers")
542 go (Just leftover) (Partial fun) = do
543 go Nothing (fun (Just leftover))
544 go Nothing (Partial fun) = do
545 -- putStrLn "before hGetSome"
546 b <- B.hGetSome h (32*1024)
547 -- printf "hGetSome: %d\n" (B.length b)
548 if B.null b
549 then return Nothing
550 else go Nothing (fun (Just b))
551 go _lft (Fail _rest _off str) =
552 throwIO (ErrorCall ("getBin: " ++ str))