module GHCi.Message
( Message(..), Msg(..)
, THMessage(..), THMsg(..)
, QResult(..)
, EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
, SerializableException(..)
, toSerializableException, fromSerializableException
, THResult(..), THResultType(..)
, ResumeContext(..)
, QState(..)
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe
) where
import Prelude
import GHCi.RemoteTypes
import GHCi.FFI
import GHCi.TH.Binary ()
import GHCi.BreakArray
import GHC.LanguageExtensions
import qualified GHC.Exts.Heap as Heap
import GHC.ForeignSrcLang
import GHC.Fingerprint
import Control.Concurrent
import Control.Exception
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Dynamic
import Data.Typeable (TypeRep)
import Data.IORef
import Data.Map (Map)
import Foreign
import GHC.Generics
import GHC.Stack.CCS
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import System.Exit
import System.IO
import System.IO.Error
data Message a where
Shutdown :: Message ()
RtsRevertCAFs :: Message ()
InitLinker :: Message ()
LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
LookupClosure :: String -> Message (Maybe HValueRef)
LoadDLL :: String -> Message (Maybe String)
LoadArchive :: String -> Message ()
LoadObj :: String -> Message ()
UnloadObj :: String -> Message ()
AddLibrarySearchPath :: String -> Message (RemotePtr ())
RemoveLibrarySearchPath :: RemotePtr () -> Message Bool
ResolveObjs :: Message Bool
FindSystemLibrary :: String -> Message (Maybe String)
CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
FreeHValueRefs :: [HValueRef] -> Message ()
AddSptEntry :: Fingerprint -> HValueRef -> Message ()
MallocData :: ByteString -> Message (RemotePtr ())
MallocStrings :: [ByteString] -> Message [RemotePtr ()]
PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
FreeFFI :: RemotePtr C_ffi_cif -> Message ()
MkConInfoTable
:: Bool
-> Int
-> Int
-> Int
-> Int
-> ByteString
-> Message (RemotePtr Heap.StgInfoTable)
EvalStmt
:: EvalOpts
-> EvalExpr HValueRef
-> Message (EvalStatus [HValueRef])
ResumeStmt
:: EvalOpts
-> RemoteRef (ResumeContext [HValueRef])
-> Message (EvalStatus [HValueRef])
AbandonStmt
:: RemoteRef (ResumeContext [HValueRef])
-> Message ()
EvalString
:: HValueRef
-> Message (EvalResult String)
EvalStringToString
:: HValueRef
-> String
-> Message (EvalResult String)
EvalIO
:: HValueRef
-> Message (EvalResult ())
MkCostCentres
:: String
-> [(String,String)]
-> Message [RemotePtr CostCentre]
CostCentreStackInfo
:: RemotePtr CostCentreStack
-> Message [String]
NewBreakArray
:: Int
-> Message (RemoteRef BreakArray)
SetupBreakpoint
:: RemoteRef BreakArray
-> Int
-> Int
-> Message ()
BreakpointStatus
:: RemoteRef BreakArray
-> Int
-> Message Bool
GetBreakpointVar
:: HValueRef
-> Int
-> Message (Maybe HValueRef)
StartTH :: Message (RemoteRef (IORef QState))
RunTH
:: RemoteRef (IORef QState)
-> HValueRef
-> THResultType
-> Maybe TH.Loc
-> Message (QResult ByteString)
RunModFinalizers :: RemoteRef (IORef QState)
-> [RemoteRef (TH.Q ())]
-> Message (QResult ())
GetClosure
:: HValueRef
-> Message (Heap.GenClosure HValueRef)
Seq
:: HValueRef
-> Message (EvalStatus ())
ResumeSeq
:: RemoteRef (ResumeContext ())
-> Message (EvalStatus ())
deriving instance Show (Message a)
data QResult a
= QDone a
| QException String
| QFail String
deriving (Generic, Show)
instance Binary a => Binary (QResult a)
data THMessage a where
NewName :: String -> THMessage (THResult TH.Name)
Report :: Bool -> String -> THMessage (THResult ())
LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name))
Reify :: TH.Name -> THMessage (THResult TH.Info)
ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity))
ReifyType :: TH.Name -> THMessage (THResult TH.Type)
ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
ReifyAnnotations :: TH.AnnLookup -> TypeRep
-> THMessage (THResult [ByteString])
ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)
ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
AddDependentFile :: FilePath -> THMessage (THResult ())
AddTempFile :: String -> THMessage (THResult FilePath)
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddCorePlugin :: String -> THMessage (THResult ())
AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool)
ExtsEnabled :: THMessage (THResult [Extension])
PutDoc :: TH.DocLoc -> String -> THMessage (THResult ())
GetDoc :: TH.DocLoc -> THMessage (THResult (Maybe String))
StartRecover :: THMessage ()
EndRecover :: Bool -> THMessage ()
FailIfErrs :: THMessage (THResult ())
RunTHDone :: THMessage ()
deriving instance Show (THMessage a)
data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a)
getTHMessage :: Get THMsg
getTHMessage = do
b <- getWord8
case b of
0 -> THMsg <$> NewName <$> get
1 -> THMsg <$> (Report <$> get <*> get)
2 -> THMsg <$> (LookupName <$> get <*> get)
3 -> THMsg <$> Reify <$> get
4 -> THMsg <$> ReifyFixity <$> get
5 -> THMsg <$> (ReifyInstances <$> get <*> get)
6 -> THMsg <$> ReifyRoles <$> get
7 -> THMsg <$> (ReifyAnnotations <$> get <*> get)
8 -> THMsg <$> ReifyModule <$> get
9 -> THMsg <$> ReifyConStrictness <$> get
10 -> THMsg <$> AddDependentFile <$> get
11 -> THMsg <$> AddTempFile <$> get
12 -> THMsg <$> AddTopDecls <$> get
13 -> THMsg <$> (IsExtEnabled <$> get)
14 -> THMsg <$> return ExtsEnabled
15 -> THMsg <$> return StartRecover
16 -> THMsg <$> EndRecover <$> get
17 -> THMsg <$> return FailIfErrs
18 -> return (THMsg RunTHDone)
19 -> THMsg <$> AddModFinalizer <$> get
20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
21 -> THMsg <$> AddCorePlugin <$> get
22 -> THMsg <$> ReifyType <$> get
23 -> THMsg <$> (PutDoc <$> get <*> get)
24 -> THMsg <$> GetDoc <$> get
n -> error ("getTHMessage: unknown message " ++ show n)
putTHMessage :: THMessage a -> Put
putTHMessage m = case m of
NewName a -> putWord8 0 >> put a
Report a b -> putWord8 1 >> put a >> put b
LookupName a b -> putWord8 2 >> put a >> put b
Reify a -> putWord8 3 >> put a
ReifyFixity a -> putWord8 4 >> put a
ReifyInstances a b -> putWord8 5 >> put a >> put b
ReifyRoles a -> putWord8 6 >> put a
ReifyAnnotations a b -> putWord8 7 >> put a >> put b
ReifyModule a -> putWord8 8 >> put a
ReifyConStrictness a -> putWord8 9 >> put a
AddDependentFile a -> putWord8 10 >> put a
AddTempFile a -> putWord8 11 >> put a
AddTopDecls a -> putWord8 12 >> put a
IsExtEnabled a -> putWord8 13 >> put a
ExtsEnabled -> putWord8 14
StartRecover -> putWord8 15
EndRecover a -> putWord8 16 >> put a
FailIfErrs -> putWord8 17
RunTHDone -> putWord8 18
AddModFinalizer a -> putWord8 19 >> put a
AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a
AddCorePlugin a -> putWord8 21 >> put a
ReifyType a -> putWord8 22 >> put a
PutDoc l s -> putWord8 23 >> put l >> put s
GetDoc l -> putWord8 24 >> put l
data EvalOpts = EvalOpts
{ useSandboxThread :: Bool
, singleStep :: Bool
, breakOnException :: Bool
, breakOnError :: Bool
}
deriving (Generic, Show)
instance Binary EvalOpts
data ResumeContext a = ResumeContext
{ resumeBreakMVar :: MVar ()
, resumeStatusMVar :: MVar (EvalStatus a)
, resumeThreadId :: ThreadId
}
data EvalExpr a
= EvalThis a
| EvalApp (EvalExpr a) (EvalExpr a)
deriving (Generic, Show)
instance Binary a => Binary (EvalExpr a)
type EvalStatus a = EvalStatus_ a a
data EvalStatus_ a b
= EvalComplete Word64 (EvalResult a)
| EvalBreak Bool
HValueRef
Int
Int
(RemoteRef (ResumeContext b))
(RemotePtr CostCentreStack)
deriving (Generic, Show)
instance Binary a => Binary (EvalStatus_ a b)
data EvalResult a
= EvalException SerializableException
| EvalSuccess a
deriving (Generic, Show)
instance Binary a => Binary (EvalResult a)
data SerializableException
= EUserInterrupt
| EExitCode ExitCode
| EOtherException String
deriving (Generic, Show)
toSerializableException :: SomeException -> SerializableException
toSerializableException ex
| Just UserInterrupt <- fromException ex = EUserInterrupt
| Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
| otherwise = EOtherException (show (ex :: SomeException))
fromSerializableException :: SerializableException -> SomeException
fromSerializableException EUserInterrupt = toException UserInterrupt
fromSerializableException (EExitCode c) = toException c
fromSerializableException (EOtherException str) = toException (ErrorCall str)
instance Binary ExitCode
instance Binary SerializableException
data THResult a
= THException String
| THComplete a
deriving (Generic, Show)
instance Binary a => Binary (THResult a)
data THResultType = THExp | THPat | THType | THDec | THAnnWrapper
deriving (Enum, Show, Generic)
instance Binary THResultType
data QState = QState
{ qsMap :: Map TypeRep Dynamic
, qsLocation :: Maybe TH.Loc
, qsPipe :: Pipe
}
instance Show QState where show _ = "<QState>"
instance Binary (Ptr a) where
put p = put (fromIntegral (ptrToWordPtr p) :: Word64)
get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64)
instance Binary (FunPtr a) where
put = put . castFunPtrToPtr
get = castPtrToFunPtr <$> get
#if MIN_VERSION_ghc_heap(8,11,0)
instance Binary Heap.StgTSOProfInfo
instance Binary Heap.CostCentreStack
instance Binary Heap.CostCentre
instance Binary Heap.IndexTable
instance Binary Heap.WhatNext
instance Binary Heap.WhyBlocked
instance Binary Heap.TsoFlags
#endif
instance Binary Heap.StgInfoTable
instance Binary Heap.ClosureType
instance Binary Heap.PrimType
instance Binary a => Binary (Heap.GenClosure a)
data Msg = forall a . (Binary a, Show a) => Msg (Message a)
getMessage :: Get Msg
getMessage = do
b <- getWord8
case b of
0 -> Msg <$> return Shutdown
1 -> Msg <$> return InitLinker
2 -> Msg <$> LookupSymbol <$> get
3 -> Msg <$> LookupClosure <$> get
4 -> Msg <$> LoadDLL <$> get
5 -> Msg <$> LoadArchive <$> get
6 -> Msg <$> LoadObj <$> get
7 -> Msg <$> UnloadObj <$> get
8 -> Msg <$> AddLibrarySearchPath <$> get
9 -> Msg <$> RemoveLibrarySearchPath <$> get
10 -> Msg <$> return ResolveObjs
11 -> Msg <$> FindSystemLibrary <$> get
12 -> Msg <$> CreateBCOs <$> get
13 -> Msg <$> FreeHValueRefs <$> get
14 -> Msg <$> MallocData <$> get
15 -> Msg <$> MallocStrings <$> get
16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
17 -> Msg <$> FreeFFI <$> get
18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)
19 -> Msg <$> (EvalStmt <$> get <*> get)
20 -> Msg <$> (ResumeStmt <$> get <*> get)
21 -> Msg <$> (AbandonStmt <$> get)
22 -> Msg <$> (EvalString <$> get)
23 -> Msg <$> (EvalStringToString <$> get <*> get)
24 -> Msg <$> (EvalIO <$> get)
25 -> Msg <$> (MkCostCentres <$> get <*> get)
26 -> Msg <$> (CostCentreStackInfo <$> get)
27 -> Msg <$> (NewBreakArray <$> get)
28 -> Msg <$> (SetupBreakpoint <$> get <*> get <*> get)
29 -> Msg <$> (BreakpointStatus <$> get <*> get)
30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
31 -> Msg <$> return StartTH
32 -> Msg <$> (RunModFinalizers <$> get <*> get)
33 -> Msg <$> (AddSptEntry <$> get <*> get)
34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
35 -> Msg <$> (GetClosure <$> get)
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
putMessage :: Message a -> Put
putMessage m = case m of
Shutdown -> putWord8 0
InitLinker -> putWord8 1
LookupSymbol str -> putWord8 2 >> put str
LookupClosure str -> putWord8 3 >> put str
LoadDLL str -> putWord8 4 >> put str
LoadArchive str -> putWord8 5 >> put str
LoadObj str -> putWord8 6 >> put str
UnloadObj str -> putWord8 7 >> put str
AddLibrarySearchPath str -> putWord8 8 >> put str
RemoveLibrarySearchPath ptr -> putWord8 9 >> put ptr
ResolveObjs -> putWord8 10
FindSystemLibrary str -> putWord8 11 >> put str
CreateBCOs bco -> putWord8 12 >> put bco
FreeHValueRefs val -> putWord8 13 >> put val
MallocData bs -> putWord8 14 >> put bs
MallocStrings bss -> putWord8 15 >> put bss
PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
FreeFFI p -> putWord8 17 >> put p
MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d
EvalStmt opts val -> putWord8 19 >> put opts >> put val
ResumeStmt opts val -> putWord8 20 >> put opts >> put val
AbandonStmt val -> putWord8 21 >> put val
EvalString val -> putWord8 22 >> put val
EvalStringToString str val -> putWord8 23 >> put str >> put val
EvalIO val -> putWord8 24 >> put val
MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs
CostCentreStackInfo ptr -> putWord8 26 >> put ptr
NewBreakArray sz -> putWord8 27 >> put sz
SetupBreakpoint arr ix cnt -> putWord8 28 >> put arr >> put ix >> put cnt
BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix
GetBreakpointVar a b -> putWord8 30 >> put a >> put b
StartTH -> putWord8 31
RunModFinalizers a b -> putWord8 32 >> put a >> put b
AddSptEntry a b -> putWord8 33 >> put a >> put b
RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty
GetClosure a -> putWord8 35 >> put a
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
data Pipe = Pipe
{ pipeRead :: Handle
, pipeWrite :: Handle
, pipeLeftovers :: IORef (Maybe ByteString)
}
remoteCall :: Binary a => Pipe -> Message a -> IO a
remoteCall pipe msg = do
writePipe pipe (putMessage msg)
readPipe pipe get
remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a
remoteTHCall pipe msg = do
writePipe pipe (putTHMessage msg)
readPipe pipe get
writePipe :: Pipe -> Put -> IO ()
writePipe Pipe{..} put
| LB.null bs = return ()
| otherwise = do
LB.hPut pipeWrite bs
hFlush pipeWrite
where
bs = runPut put
readPipe :: Pipe -> Get a -> IO a
readPipe Pipe{..} get = do
leftovers <- readIORef pipeLeftovers
m <- getBin pipeRead get leftovers
case m of
Nothing -> throw $
mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing
Just (result, new_leftovers) -> do
writeIORef pipeLeftovers new_leftovers
return result
getBin
:: Handle -> Get a -> Maybe ByteString
-> IO (Maybe (a, Maybe ByteString))
getBin h get leftover = go leftover (runGetIncremental get)
where
go Nothing (Done leftover _ msg) =
return (Just (msg, if B.null leftover then Nothing else Just leftover))
go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers")
go (Just leftover) (Partial fun) = do
go Nothing (fun (Just leftover))
go Nothing (Partial fun) = do
b <- B.hGetSome h (32*1024)
if B.null b
then return Nothing
else go Nothing (fun (Just b))
go _lft (Fail _rest _off str) =
throwIO (ErrorCall ("getBin: " ++ str))