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