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))