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